hint 0.3.3.7 → 0.4.0.0
raw patch · 18 files changed
+380/−304 lines, 18 filesdep +HUnitdep +exceptionsdep +hintdep −MonadCatchIO-mtldep −haskell-srcdep ~basedep ~ghc-mtl
Dependencies added: HUnit, exceptions, hint
Dependencies removed: MonadCatchIO-mtl, haskell-src
Dependency ranges changed: base, ghc-mtl
Files
- AUTHORS +1/−0
- CHANGELOG.markdown +135/−0
- Changes +0/−99
- README +11/−7
- hint.cabal +22/−13
- src/Hint/Base.hs +43/−24
- src/Hint/Compat.hs +11/−6
- src/Hint/Configuration.hs +3/−2
- src/Hint/Context.hs +23/−17
- src/Hint/Conversions.hs +20/−37
- src/Hint/GHC.hs +7/−5
- src/Hint/InterpreterT.hs +47/−50
- src/Hint/Reflection.hs +8/−0
- src/Hint/Sandbox.hs +7/−7
- src/Hint/SignalHandlers.hs +7/−7
- src/Hint/Typecheck.hs +5/−5
- src/Language/Haskell/Interpreter/Unsafe.hs +3/−2
- unit-tests/run-unit-tests.hs +27/−23
AUTHORS view
@@ -13,3 +13,4 @@ Conrad Parker Mark Wright Bertram Felgenhauer+Samuel Gélineau
+ CHANGELOG.markdown view
@@ -0,0 +1,135 @@+0.4.0.0+-------+ * Compiles with ghc 7.8++ * Fixed an issue where "P" was available as a qualified version of Prelude+ (thanks to Samuel Gélineau)++ * Uses exceptions package instead of MonadCatchIO-mtl (API breakage expected)++ * No longer depends on haskell-src++ * Changelog should now appear in Hackage++ * Integrated unit tests with cabal++0.3.3.7+-------+ * Fixed a race condition that would happen, for instance, when two process where run+ one next to the other, making them, on some platforms, to get the same random number seed+ (thanks to Mario Pastorelli and Samuel Gélineau)++ * Small fix in documentation (thanks to Daniil Frumin)++0.3.3.6+-------+ * Works again on GHC 7.2.x (thanks to Björn Peemöller)++0.3.3.5+-------+ * Works on GHC 7.4.6+ * Cleans up files for phantom modules that were left behind (thanks to Beltram Felgenhauer)++0.3.3.4+-------+ * Works on GHC 7.4.1++0.3.3.3+-------+ * Works on GHC 7.2.1++0.3.3.2+-------+ * Supports GHC 7++0.3.3.1+-------+ * Instance declaration for Applicative (InterpreterT m) works with mtl-2+ (requires Applicative m, this shouldn't break anything...)++0.3.3.0+-------+ * add unsafeRunInterpreterWithArgs+ * check that only one instance of the interpreter is run at any time++0.3.2.3+-------+ * Can be built against MonadCatchIO-mtl-0.3.x.x++0.3.2.2+-------+ * Fixed a bug that would make expressions using heavy use of the layout+ rule to fail to be interpreted (see parens)++0.3.2.1+-------+ * hint.cabal includes version bounds for package ghc-mtl. This is to+ avoid the accidental selection of the completely unrelated ghc-mtl+ internal to ghc and, apparently, installed in the hackage server++0.3.2.0+-------+ * Exports functions parens and isInterpretedModule++ * Experimental support for module annotations++ * Uses extensible-exceptions in order to provide a uniform interface+ accross different ghc versions++ * Provides an Applicative instance for IntepreterT++ * Adds an option to configurate the searchPath+++0.3.1.0+-------+ * No longer uses Language.Haskell.Extension due to configuration problems with Cabal.+ Instead, it uses its own Language.Haskell.Interpreter.Extension module.++0.3.0.0+-------+ * Updated API:+ + InterpreterT monad transformer (Interpreter = InterpreterT IO)+ + No more Sessions, use runInterpreter only once+ + New options handling functions+ - but observe that there is no setOptimizations equivalent;+ since GHC does no optimization on interpreted code, this was actually+ doing nothing+ * Works with GHC 6.10 and 6.8 (untested with 6.6)++0.2.5+-----+ * setImportsQ added (modules can be imported both qualified and unqualified)++0.2.4.1+-------+ * BUGFIX: No longer fails on expressions ending in a -- comment++0.2.4+-----+ * setInstalledModsAreInScopeQualified added+ * Now depends on ghc-paths (no longer needs a custom cabal script)++0.2.2+-----+ * setOptimizations added+ * Module Language.Haskell.Interpreter.GHC.Unsafe added+ (contains unsafeSetGhcOption)+ * unit tests now based on HUnit++0.2.1+-----+ * BUGFIX: Module reloading was broken under 6.8+ * GHC.GhcExceptions are catched and turned into InterpreterErrors++0.2.0.1+-------+ * Adds the requirement cabal-version < 1.3++0.2+---++ * Works also with GHC 6.8 and 6.6+ * Added the getModuleExports function+ * withSession function throws a dynamic exception instead of returning Either Error a+ * Requires Cabal 1.2.x
− Changes
@@ -1,99 +0,0 @@-- ver 0.3.3.7- * Fixed a race condition that would happen, for instance, when two process where run- one next to the other, making them, on some platforms, to get the same random number seed- (thanks to Mario Pastorelli and Samuel Gélineau)-- * Small fix in documentation (thanks to Daniil Frumin)--- ver 0.3.3.6- * Works again on GHC 7.2.x (thanks to Björn Peemöller)--- ver 0.3.3.5- * Works on GHC 7.4.6- * Cleans up files for phantom modules that were left behind (thanks to Beltram Felgenhauer)--- ver 0.3.3.4- * Works on GHC 7.4.1--- ver 0.3.3.3- * Works on GHC 7.2.1--- ver 0.3.3.2- * Supports GHC 7--- ver 0.3.3.1- * Instance declaration for Applicative (InterpreterT m) works with mtl-2- (requires Applicative m, this shouldn't break anything...)--- ver 0.3.3.0- * add unsafeRunInterpreterWithArgs- * check that only one instance of the interpreter is run at any time--- ver 0.3.2.3- * Can be built against MonadCatchIO-mtl-0.3.x.x--- ver 0.3.2.2- * Fixed a bug that would make expressions using heavy use of the layout- rule to fail to be interpreted (see parens)--- ver 0.3.2.1- * hint.cabal includes version bounds for package ghc-mtl. This is to- avoid the accidental selection of the completely unrelated ghc-mtl- internal to ghc and, apparently, installed in the hackage server--- ver 0.3.2.0- * Exports functions parens and isInterpretedModule-- * Experimental support for module annotations-- * Uses extensible-exceptions in order to provide a uniform interface- accross different ghc versions-- * Provides an Applicative instance for IntepreterT-- * Adds an option to configurate the searchPath---- ver 0.3.1.0- * No longer uses Language.Haskell.Extension due to configuration problems with Cabal.- Instead, it uses its own Language.Haskell.Interpreter.Extension module.--- ver 0.3.0.0- * Updated API:- + InterpreterT monad transformer (Interpreter = InterpreterT IO)- + No more Sessions, use runInterpreter only once- + New options handling functions- - but observe that there is no setOptimizations equivalent;- since GHC does no optimization on interpreted code, this was actually- doing nothing- * Works with GHC 6.10 and 6.8 (untested with 6.6)--- ver 0.2.5- * setImportsQ added (modules can be imported both qualified and unqualified)--- ver 0.2.4.1- * BUGFIX: No longer fails on expressions ending in a -- comment--- ver 0.2.4- * setInstalledModsAreInScopeQualified added- * Now depends on ghc-paths (no longer needs a custom cabal script)--- 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--- ver 0.2.0.1- * Adds the requirement cabal-version < 1.3--- ver 0.2-- * Works also with GHC 6.8 and 6.6- * Added the getModuleExports function- * withSession function throws a dynamic exception instead of returning Either Error a- * Requires Cabal 1.2.x
README view
@@ -1,11 +1,15 @@-=== Installation ===-To install locally:+=== Description === -> runhaskell Setup.lhs configure --prefix=$HOME --user-> runhaskell Setup.lhs build-> runhaskell Setup.lhs haddock-> runhaskell Setup.lhs install+This library defines an Interpreter monad. It allows to load Haskell+modules, browse them, type-check and evaluate strings with Haskell+expressions and even coerce them into values. The library is+thread-safe and type-safe (even the coercion of expressions to+values). +It is, esentially, a huge subset of the GHC API wrapped in a simpler+API.++ === Documentation === The library cames with haddock documentation you can build@@ -20,5 +24,5 @@ To get a copy of the darcs repository: -darcs get http://darcsden.com/jcpetruzza/hint+darcs get http://hub.darcs.net/jcpetruzza/hint
hint.cabal view
@@ -1,5 +1,5 @@ name: hint-version: 0.3.3.7+version: 0.4.0.0 description: This library defines an @Interpreter@ monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell@@ -8,45 +8,54 @@ values). It is, esentially, a huge subset of the GHC API wrapped in a simpler- API. Works with GHC 6.10.x and 6.8.x- (this version was not tested with GHC 6.6).+ API. synopsis: Runtime Haskell interpreter (GHC API wrapper) category: Language, Compilers/Interpreters license: BSD3 license-file: LICENSE author: Daniel Gorin maintainer: jcpetruzza@gmail.com-homepage: http://darcsden.com/jcpetruzza/hint+homepage: http://hub.darcs.net/jcpetruzza/hint -cabal-version: >= 1.2.3+cabal-version: >= 1.9.2 build-type: Simple tested-with: GHC==6.8.3, GHC==6.10 extra-source-files: README AUTHORS- Changes+ CHANGELOG.markdown examples/example.hs examples/SomeModule.hs- unit-tests/run-unit-tests.hs +Test-Suite unit-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: unit-tests+ main-is: run-unit-tests.hs+ build-depends: base < 5+ ,hint+ ,HUnit==1.2.*+ ,directory+ ,filepath+ ,mtl+ ,extensible-exceptions+ ,exceptions >= 0.3.2, exceptions < 0.4+ Library- build-depends: haskell-src,- ghc > 6.6,+ build-depends: ghc > 6.6, ghc-paths, mtl, filepath, utf8-string, extensible-exceptions,- MonadCatchIO-mtl >= 0.3+ exceptions >= 0.3.2, exceptions < 0.4 if impl(ghc >= 6.8) { build-depends: random, directory if impl(ghc >= 6.10) { build-depends: base >= 4, base < 5,- ghc-mtl >= 1.0.1.0, ghc-mtl < 1.1.0.0- -- this is to protect against the accidental selection- -- of the completely unrelated ghc'c ghc-mtl package+ ghc-mtl == 1.1.*+ -- version 1.1.* uses exceptions instead of MonadCatchIO } else { build-depends: base >= 3, base < 4 }
src/Hint/Base.hs view
@@ -1,7 +1,7 @@ module Hint.Base ( MonadInterpreter(..), RunGhc, --- GhcError(..), InterpreterError(..), mayFail,+ GhcError(..), InterpreterError(..), mayFail, catchIE, -- InterpreterSession, SessionData(..), GhcErrLogger, InterpreterState(..), fromState, onState,@@ -11,14 +11,17 @@ -- ModuleName, PhantomModule(..), findModule, moduleIsLoaded,+ withDynFlags, --- ghcVersion+ ghcVersion,+ --+ debug, showGHC ) where -import Control.Monad.Error-import Control.Monad.CatchIO+import Control.Monad.Trans+import Control.Monad.Catch as MC import Data.IORef import Data.Dynamic@@ -26,6 +29,7 @@ import qualified Hint.GHC as GHC import Hint.Extension+import Hint.Compat as Compat -- | Version of the underlying ghc api. Values are: --@@ -39,8 +43,7 @@ ghcVersion :: Int ghcVersion = __GLASGOW_HASKELL__ --- this requires FlexibleContexts-class (MonadCatchIO m,MonadError InterpreterError m) => MonadInterpreter m where+class (MonadIO m, MonadCatch m) => MonadInterpreter m where fromSession :: FromSession m a modifySessionRef :: ModifySessionRef m a runGhc :: RunGhc m a@@ -58,10 +61,6 @@ | GhcException String deriving (Show, Typeable) -instance Error InterpreterError where- noMsg = UnknownError ""- strMsg = UnknownError- data InterpreterState = St{active_phantoms :: [PhantomModule], zombie_phantoms :: [PhantomModule], hint_support_module :: PhantomModule,@@ -107,27 +106,27 @@ adjust = id type RunGhc m a =- (forall n.(MonadCatchIO n,Functor n) => GHC.GhcT n a)+ (forall n.(MonadIO n, MonadCatch n,Functor n) => GHC.GhcT n a) -> m a type RunGhc1 m a b =- (forall n.(MonadCatchIO n, Functor n) => a -> GHC.GhcT n b)+ (forall n.(MonadIO n, MonadCatch n, Functor n) => a -> GHC.GhcT n b) -> (a -> m b) type RunGhc2 m a b c =- (forall n.(MonadCatchIO n, Functor n) => a -> b -> GHC.GhcT n c)+ (forall n.(MonadIO n, MonadCatch n, Functor n) => a -> b -> GHC.GhcT n c) -> (a -> b -> m c) type RunGhc3 m a b c d =- (forall n.(MonadCatchIO n, Functor n) => a -> b -> c -> GHC.GhcT n d)+ (forall n.(MonadIO n, MonadCatch n, Functor n) => a -> b -> c -> GHC.GhcT n d) -> (a -> b -> c -> m d) type RunGhc4 m a b c d e =- (forall n.(MonadCatchIO n, Functor n) => a -> b -> c -> d -> GHC.GhcT n e)+ (forall n.(MonadIO n, MonadCatch n, Functor n) => a -> b -> c -> d -> GHC.GhcT n e) -> (a -> b -> c -> d -> m e) type RunGhc5 m a b c d e f =- (forall n.(MonadCatchIO n, Functor n) => a->b->c->d->e->GHC.GhcT n f)+ (forall n.(MonadIO n, MonadCatch n, Functor n) => a->b->c->d->e->GHC.GhcT n f) -> (a -> b -> c -> d -> e -> m f) #endif @@ -152,10 +151,14 @@ -> m a mapGhcExceptions buildEx action = do action- `catchError` (\err -> case err of- GhcException s -> throwError (buildEx s)- _ -> throwError err)+ `MC.catch` (\err -> case err of+ GhcException s -> throwM (buildEx s)+ _ -> throwM err) +catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a+catchIE = MC.catch++ #if __GLASGOW_HASKELL__ < 704 type GhcErrLogger = GHC.Severity -> GHC.SrcSpan@@ -204,12 +207,23 @@ es <- modifySessionRef ghcErrListRef (const []) -- case (maybe_res, null es) of- (Nothing,True) -> throwError $ UnknownError "Got no error message"- (Nothing,False) -> throwError $ WontCompile (reverse es)+ (Nothing,True) -> throwM $ UnknownError "Got no error message"+ (Nothing,False) -> throwM $ WontCompile (reverse es) (Just a, True) -> return a (Just _, False) -> fail $ "GHC returned a result but said: " ++ show es +-- ================= Debugging stuff ===============++debug :: MonadInterpreter m => String -> m ()+debug = liftIO . putStrLn . ("!! " ++)++showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String+showGHC a+ = do unqual <- runGhc GHC.getPrintUnqual+ withDynFlags $ \df ->+ return $ Compat.showSDocForUser df unqual (GHC.ppr a)+ -- ================ Misc =================================== -- this type ought to go in Hint.Context, but ghc dislikes cyclic imports...@@ -224,6 +238,11 @@ moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool moduleIsLoaded mn = (findModule mn >> return True)- `catchError` (\e -> case e of- NotAllowed{} -> return False- _ -> throwError e)+ `catchIE` (\e -> case e of+ NotAllowed{} -> return False+ _ -> throwM e)++withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a+withDynFlags action+ = do df <- runGhc GHC.getSessionDynFlags+ action df
src/Hint/Compat.hs view
@@ -207,8 +207,13 @@ pprKind = pprType #else -- 7.2.1 and above+ pprType :: GHC.Type -> GHC.SDoc+#if __GLASGOW_HASKELL__ < 708 pprType = GHC.pprTypeForUser False -- False means drop explicit foralls+#else+pprType = GHC.pprTypeForUser+#endif pprKind :: GHC.Kind -> GHC.SDoc pprKind = pprType@@ -232,14 +237,14 @@ #endif #if __GLASGOW_HASKELL__ >= 706- -- why did they have to add a DynFlag to each showSDocXXX function.... (sigh)-showSDoc = GHC.showSDoc GHC.tracingDynFlags -- hack!-showSDocForUser = GHC.showSDocForUser GHC.tracingDynFlags -- hack!+showSDoc = GHC.showSDoc+showSDocForUser = GHC.showSDocForUser showSDocUnqual = GHC.showSDocUnqual #else-showSDoc = GHC.showSDoc-showSDocForUser = GHC.showSDocForUser-showSDocUnqual = const GHC.showSDocUnqual+ -- starting from ghc 7.6, they started to receive a DynFlags argument (sigh)+showSDoc _ = GHC.showSDoc+showSDocForUser _ = GHC.showSDocForUser+showSDocUnqual _ = GHC.showSDocUnqual #endif
src/Hint/Configuration.hs view
@@ -15,7 +15,8 @@ searchPath ) where -import Control.Monad.Error+import Control.Monad+import Control.Monad.Catch import Data.Char import Data.List ( intersect, intercalate ) @@ -31,7 +32,7 @@ do old_flags <- runGhc GHC.getSessionDynFlags (new_flags,not_parsed) <- runGhc2 Compat.parseDynamicFlags old_flags opts when (not . null $ not_parsed) $- throwError $ UnknownError+ throwM $ UnknownError $ concat ["flags: ", unwords $ map quote not_parsed, "not recognized"] _ <- runGhc1 GHC.setSessionDynFlags new_flags
src/Hint/Context.hs view
@@ -22,7 +22,8 @@ import Data.List import Control.Monad ( liftM, filterM, when, guard )-import Control.Monad.Error ( catchError, throwError, liftIO )+import Control.Monad.Trans ( liftIO )+import Control.Monad.Catch import Hint.Base import Hint.Util ( (>=>) ) -- compat version@@ -85,10 +86,10 @@ then do runGhc2 Compat.setContext old_top old_imps return $ Just () else return Nothing)- `catchError` (\err -> case err of- WontCompile _ -> do removePhantomModule pm- throwError err- _ -> throwError err)+ `catchIE` (\err -> case err of+ WontCompile _ -> do removePhantomModule pm+ throwM err+ _ -> throwM err) -- return pm @@ -111,7 +112,7 @@ let mods' = filter (mod /=) mods runGhc2 Compat.setContext mods' imps --- let isNotPhantom = isPhantomModule . fromGhcRep_ >=>+ let isNotPhantom = isPhantomModule . moduleToString >=> return . not null `liftM` filterM isNotPhantom mods' else return True@@ -147,8 +148,9 @@ loadModules :: MonadInterpreter m => [String] -> m () loadModules fs = do -- first, unload everything, and do some clean-up reset- doLoad fs `catchError` (\e -> reset >> throwError e)+ doLoad fs `catchIE` (\e -> reset >> throwM e) + doLoad :: MonadInterpreter m => [String] -> m () doLoad fs = do mayFail $ do targets <- mapM (\f->runGhc2 Compat.guessTarget f Nothing) fs@@ -170,7 +172,7 @@ return $ ms \\ (map pm_name $ active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName-modNameFromSummary = fromGhcRep_ . GHC.ms_mod+modNameFromSummary = moduleToString . GHC.ms_mod getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary] getLoadedModSummaries =@@ -187,8 +189,8 @@ -- let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc when (not . null $ not_loaded) $- throwError $ NotAllowed ("These modules have not been loaded:\n" ++- unlines not_loaded)+ throwM $ NotAllowed ("These modules have not been loaded:\n" +++ unlines not_loaded) -- active_pms <- fromState active_phantoms ms_mods <- mapM findModule (nub $ ms ++ map pm_name active_pms)@@ -196,8 +198,8 @@ let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods when (not . null $ not_interpreted) $- throwError $ NotAllowed ("These modules are not interpreted:\n" ++- unlines (map fromGhcRep_ not_interpreted))+ throwM $ NotAllowed ("These modules are not interpreted:\n" +++ unlines (map moduleToString not_interpreted)) -- (_, old_imports) <- runGhc Compat.getContext runGhc2 Compat.setContext ms_mods old_imports@@ -207,7 +209,7 @@ do (old_mods, old_imps) <- runGhc Compat.getContext runGhc2 Compat.setContext [] [] let restore = runGhc2 Compat.setContext old_mods old_imps- a <- action `catchError` (\e -> do restore; throwError e)+ a <- action `catchIE` (\e -> do restore; throwM e) restore return a @@ -306,15 +308,16 @@ " " ++ _show ++ ")", "where", "",- "import qualified Prelude as P",+ "import qualified Prelude as " ++ _P ++ " (String, Show(show))", "",- "type " ++ _String ++ " = P.String",+ "type " ++ _String ++ " = " ++ _P ++ ".String", "",- _show ++ " :: P.Show a => a -> P.String",- _show ++ " = P.show"+ _show ++ " :: " ++ _P ++ ".Show a => a -> " ++ _P ++ ".String",+ _show ++ " = " ++ _P ++ ".show" ] where _String = altStringName m _show = altShowName m+ _P = altPreludeName m -- Call it when the support module is an active phantom module but has been -- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets)@@ -328,6 +331,9 @@ altShowName :: ModuleName -> String altShowName mod_name = "show_" ++ mod_name++altPreludeName :: ModuleName -> String+altPreludeName mod_name = "Prelude_" ++ mod_name support_String :: MonadInterpreter m => m String support_String = do mod_name <- fromState (pm_name . hint_support_module)
src/Hint/Conversions.hs view
@@ -1,4 +1,10 @@-module Hint.Conversions( FromGhcRep(..), FromGhcRep_(..), isSucceeded )+module Hint.Conversions+ (+ typeToString+ ,kindToString+ ,moduleToString+ ,isSucceeded+ ) where @@ -7,51 +13,28 @@ import Hint.Base import qualified Hint.Compat as Compat -import Language.Haskell.Syntax ( HsModule(..), HsDecl(..), HsQualType )-import Language.Haskell.Parser ( parseModule, ParseResult(ParseOk) ) --- | Conversions from GHC representation to standard representations-class FromGhcRep ghc target where- fromGhcRep :: MonadInterpreter m => ghc -> m target--class FromGhcRep_ ghc target where- fromGhcRep_ :: ghc -> target- -- --------- Types / Kinds ----------------------- -instance FromGhcRep GHC.Type HsQualType where- fromGhcRep t =- do t_str <- fromGhcRep t- --- let mod_str = unlines ["f ::" ++ t_str,- "f = undefined"]- let HsModule _ _ _ _ [decl,_] = parseModule' mod_str- HsTypeSig _ _ qualType = decl- --- return qualType --instance FromGhcRep GHC.Type String where- fromGhcRep t = do -- Unqualify necessary types- -- (i.e., do not expose internals)- unqual <- runGhc GHC.getPrintUnqual- return $ Compat.showSDocForUser unqual (Compat.pprType t)--parseModule' :: String -> HsModule-parseModule' s = case parseModule s of- ParseOk m -> m- failed -> error $ unlines ["parseModulde' failed?!",- s,- show failed]+typeToString :: MonadInterpreter m => GHC.Type -> m String+typeToString t+ = do -- Unqualify necessary types+ -- (i.e., do not expose internals)+ unqual <- runGhc GHC.getPrintUnqual+ withDynFlags $ \df ->+ return $ Compat.showSDocForUser df unqual (Compat.pprType t) -instance FromGhcRep_ Compat.Kind String where- fromGhcRep_ (Compat.Kind k) = Compat.showSDoc (Compat.pprKind k)+kindToString :: MonadInterpreter m => Compat.Kind -> m String+kindToString (Compat.Kind k)+ = withDynFlags $ \df ->+ return $ Compat.showSDoc df (Compat.pprKind k) -- ---------------- Modules -------------------------- -instance FromGhcRep_ GHC.Module String where- fromGhcRep_ = GHC.moduleNameString . GHC.moduleName+moduleToString :: GHC.Module -> String+moduleToString = GHC.moduleNameString . GHC.moduleName -- ---------------- Misc -----------------------------
src/Hint/GHC.hs view
@@ -22,6 +22,9 @@ #if __GLASGOW_HASKELL__ >= 702 module SrcLoc, #endif+#if __GLASGOW_HASKELL__ >= 708+ module ConLike,+#endif ) where@@ -35,7 +38,7 @@ import GHC hiding ( Phase ) #endif -import Outputable ( PprStyle, SDoc, ppr,+import Outputable ( PprStyle, SDoc, Outputable(ppr), showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle ) @@ -63,10 +66,6 @@ import DynFlags ( LogAction ) #endif -#if __GLASGOW_HASKELL__ >= 706-import DynFlags ( tracingDynFlags )-#endif- #if __GLASGOW_HASKELL__ >= 608 import PprTyThing ( pprTypeForUser ) #elif __GLASGOW_HASKELL__ < 608@@ -77,6 +76,9 @@ import SrcLoc ( mkRealSrcLoc ) #endif +#if __GLASGOW_HASKELL__ >= 708+import ConLike ( ConLike(RealDataCon) )+#endif #if __GLASGOW_HASKELL__ >= 706 type Message = MsgDoc
src/Hint/InterpreterT.hs view
@@ -5,7 +5,7 @@ where -import Prelude hiding ( catch )+import Prelude import Hint.Base import Hint.Context@@ -14,8 +14,7 @@ import Control.Applicative import Control.Monad.Reader-import Control.Monad.Error-import Control.Monad.CatchIO+import Control.Monad.Catch as MC import Data.Typeable ( Typeable ) import Control.Concurrent.MVar@@ -40,9 +39,9 @@ newtype InterpreterT m a = InterpreterT{ unInterpreterT :: ReaderT InterpreterSession (ErrorT InterpreterError m) a}- deriving (Functor, Monad, MonadIO, MonadCatchIO)+ deriving (Functor, Monad, MonadIO, MonadCatch) -execute :: (MonadCatchIO m, Functor m)+execute :: (MonadIO m, MonadCatch m, Functor m) => InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a)@@ -51,7 +50,7 @@ instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift -runGhc_impl :: (MonadCatchIO m, Functor m) => RunGhc (InterpreterT m) a+runGhc_impl :: (MonadIO m, MonadCatch m, Functor m) => RunGhc (InterpreterT m) a runGhc_impl f = do s <- fromSession versionSpecific -- i.e. the ghc session r <- liftIO $ f' s either throwError return r@@ -63,34 +62,36 @@ -- ghc >= 6.10 newtype InterpreterT m a = InterpreterT{ unInterpreterT :: ReaderT InterpreterSession- (ErrorT InterpreterError- (GHC.GhcT m)) a}- deriving (Functor, Monad, MonadIO, MonadCatchIO)+ (GHC.GhcT m) a}+ deriving (Functor, Monad, MonadIO, MonadCatch) -execute :: (MonadCatchIO m, Functor m)+execute :: (MonadIO m, MonadCatch m, Functor m) => InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a)-execute s = GHC.runGhcT (Just GHC.Paths.libdir)- . runErrorT+execute s = try+ . GHC.runGhcT (Just GHC.Paths.libdir) . flip runReaderT s . unInterpreterT + instance MonadTrans InterpreterT where- lift = InterpreterT . lift . lift . lift+ lift = InterpreterT . lift . lift -runGhc_impl :: (MonadCatchIO m, Functor m) => RunGhc (InterpreterT m) a-runGhc_impl a = InterpreterT (lift (lift a))- `catches`- [Handler (\(e :: GHC.SourceError) -> rethrowWC e),- Handler (\(e :: GHC.GhcApiError) -> rethrowGE $ show e),- Handler (\(e :: GHC.GhcException) -> rethrowGE $ showGhcEx e)]- where rethrowGE = throwError . GhcException- rethrowWC = throwError- . WontCompile- . map (GhcError . show)- . GHC.bagToList- . GHC.srcErrorMessages+runGhc_impl :: (MonadIO m, MonadCatch m, Functor m) => RunGhc (InterpreterT m) a+runGhc_impl a =+ InterpreterT (lift a)+ `catches`+ [Handler (\(e :: GHC.SourceError) -> throwM $ compilationError e)+ ,Handler (\(e :: GHC.GhcApiError) -> throwM $ GhcException $ show e)+ ,Handler (\(e :: GHC.GhcException) -> throwM $ GhcException $ showGhcEx e)+ ]+ where+ compilationError+ = WontCompile+ . map (GhcError . show)+ . GHC.bagToList+ . GHC.srcErrorMessages #endif showGhcEx :: GHC.GhcException -> String@@ -98,7 +99,7 @@ -- ================= Executing the interpreter ================== -initialize :: (MonadCatchIO m, Functor m)+initialize :: (MonadIO m, MonadCatch m, Functor m) => [String] -> InterpreterT m () initialize args =@@ -109,9 +110,9 @@ let df1 = Compat.configureDynFlags df0 (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args when (not . null $ extra) $- throwError $ UnknownError (concat [ "flags: '"- , intercalate " " extra- , "' not recognized"])+ throwM $ UnknownError (concat [ "flags: '"+ , intercalate " " extra+ , "' not recognized"]) -- Observe that, setSessionDynFlags loads info on packages -- available; calling this function once is mandatory!@@ -145,7 +146,7 @@ -- NB. The underlying ghc will overwrite certain signal handlers -- (SIGINT, SIGHUP, SIGTERM, SIGQUIT on Posix systems, Ctrl-C handler on Windows). -- In future versions of hint, this might be controlled by the user.-runInterpreter :: (MonadCatchIO m, Functor m)+runInterpreter :: (MonadIO m, MonadCatch m, Functor m) => InterpreterT m a -> m (Either InterpreterError a) runInterpreter = runInterpreterWithArgs []@@ -153,16 +154,16 @@ -- | Executes the interpreter, setting args passed in as though they -- were command-line args. Returns @Left InterpreterError@ in case of -- error.-runInterpreterWithArgs :: (MonadCatchIO m, Functor m)+runInterpreterWithArgs :: (MonadIO m, MonadCatch m, Functor m) => [String] -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgs args action = ifInterpreterNotRunning $- do s <- newInterpreterSession `catch` rethrowGhcException+ do s <- newInterpreterSession `MC.catch` rethrowGhcException -- SH.protectHandlers $ execute s (initialize args >> action) execute s (initialize args >> action `finally` cleanSession)- where rethrowGhcException = throw . GhcException . showGhcEx+ where rethrowGhcException = throwM . GhcException . showGhcEx #if __GLASGOW_HASKELL__ < 610 newInterpreterSession = do s <- liftIO $ Compat.newSession GHC.Paths.libdir@@ -181,11 +182,11 @@ uniqueToken :: MVar () uniqueToken = unsafePerformIO $ newMVar () -ifInterpreterNotRunning :: MonadCatchIO m => m a -> m a+ifInterpreterNotRunning :: (MonadIO m, MonadCatch m) => m a -> m a ifInterpreterNotRunning action = do maybe_token <- liftIO $ tryTakeMVar uniqueToken case maybe_token of- Nothing -> throw MultipleInstancesNotAllowed+ Nothing -> throwM MultipleInstancesNotAllowed Just x -> action `finally` (liftIO $ putMVar uniqueToken x) -- | The installed version of ghc is not thread-safe. This exception@@ -221,25 +222,26 @@ } mkLogHandler :: IORef [GhcError] -> GhcErrLogger-mkLogHandler r = compat $ \_ src style msg ->- let errorEntry = mkGhcError src style msg- in modifyIORef r (errorEntry :)- where+mkLogHandler r = #if __GLASGOW_HASKELL__ < 706- compat = id+ \_ src style msg ->+ let renderErrMsg = Compat.showSDoc () #else- compat = const -- cater for the extra DynFlags args+ \df _ src style msg ->+ let renderErrMsg = Compat.showSDoc df #endif+ errorEntry = mkGhcError renderErrMsg src style msg+ in modifyIORef r (errorEntry :) -mkGhcError :: GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError-mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg}- where niceErrMsg = Compat.showSDoc . GHC.withPprStyle style $+mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError+mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg}+ where niceErrMsg = render . GHC.withPprStyle style $ Compat.mkLocMessage src_span msg -- The MonadInterpreter instance -instance (MonadCatchIO m, Functor m) => MonadInterpreter (InterpreterT m) where+instance (MonadIO m, MonadCatch m, Functor m) => MonadInterpreter (InterpreterT m) where fromSession f = InterpreterT $ fmap f ask -- modifySessionRef target f =@@ -249,11 +251,6 @@ -- runGhc a = runGhc_impl a -instance Monad m => MonadError InterpreterError (InterpreterT m) where- throwError = InterpreterT . throwError- catchError (InterpreterT m) catchE = InterpreterT $- m `catchError`- (\e -> unInterpreterT $ catchE e) instance (Monad m, Applicative m) => Applicative (InterpreterT m) where pure = return
src/Hint/Reflection.hs view
@@ -58,7 +58,11 @@ [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], #endif+#if __GLASGOW_HASKELL__ < 708 [asModElem df d | d@GHC.ADataCon{} <- xs],+#else+ [asModElem df d | d@(GHC.AConLike (GHC.RealDataCon{})) <- xs],+#endif [asModElem df f | f@GHC.AnId{} <- xs] ) cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs]@@ -68,7 +72,11 @@ asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem asModElem df (GHC.AnId f) = Fun $ getUnqualName df f+#if __GLASGOW_HASKELL__ < 708 asModElem df (GHC.ADataCon dc) = Fun $ getUnqualName df dc+#else+asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc+#endif #if __GLASGOW_HASKELL__ < 704 asModElem df(GHC.ATyCon tc) = Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc)
src/Hint/Sandbox.hs view
@@ -7,7 +7,7 @@ import {-# SOURCE #-} Hint.Typecheck ( typeChecks_unsandboxed ) -import Control.Monad.Error+import Control.Monad.Catch sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a) sandboxed = if ghcVersion >= 610 then id else old_sandboxed@@ -50,12 +50,12 @@ let go no_prel = do pm <- addPhantomModule (mod_text no_prel) setTopLevelModules [pm_name pm] r <- do_stuff_on e- `catchError` (\err ->+ `catchIE` (\err -> case err of WontCompile _ -> do removePhantomModule pm- throwError err- _ -> throwError err)+ throwM err+ _ -> throwM err) removePhantomModule pm return r -- If the Prelude was not explicitly imported but implicitly@@ -65,9 +65,9 @@ -- I guess this may lead to even more obscure errors, but -- hopefully in much less frequent situations... r <- onAnEmptyContext $ go True- `catchError` (\err -> case err of- WontCompile _ -> go False- _ -> throwError err)+ `catchIE` (\err -> case err of+ WontCompile _ -> go False+ _ -> throwM err) -- return r --
src/Hint/SignalHandlers.hs view
@@ -3,22 +3,22 @@ ) where -import Control.Monad.CatchIO+import Control.Monad.Catch import Control.Monad.Trans #ifdef mingw32_HOST_OS import GHC.ConsoleHandler as C -saveHandlers :: MonadCatchIO m => m C.Handler+saveHandlers :: MonadIO m => m C.Handler saveHandlers = liftIO $ C.installHandler Ignore -restoreHandlers :: MonadCatchIO m => C.Handler -> m C.Handler+restoreHandlers :: MonadIO m => C.Handler -> m C.Handler restoreHandlers = liftIO . C.installHandler #else import qualified System.Posix.Signals as S -helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler+helper :: MonadIO m => S.Handler -> S.Signal -> m S.Handler helper handler signal = liftIO $ S.installHandler signal handler Nothing signals :: [S.Signal]@@ -28,13 +28,13 @@ , S.sigTERM ] -saveHandlers :: MonadCatchIO m => m [S.Handler]+saveHandlers :: MonadIO m => m [S.Handler] saveHandlers = liftIO $ mapM (helper S.Ignore) signals -restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler]+restoreHandlers :: MonadIO m => [S.Handler] -> m [S.Handler] restoreHandlers h = liftIO . sequence $ zipWith helper h signals #endif -protectHandlers :: MonadCatchIO m => m a -> m a+protectHandlers :: (MonadIO m, MonadCatch m) => m a -> m a protectHandlers a = bracket saveHandlers restoreHandlers $ const a
src/Hint/Typecheck.hs view
@@ -8,7 +8,7 @@ where -import Control.Monad.Error+import Control.Monad.Catch import Hint.Base import Hint.Parsers@@ -30,7 +30,7 @@ -- ty <- mayFail $ runGhc1 Compat.exprType expr --- fromGhcRep ty+ typeToString ty -- | Tests if the expression type checks. typeChecks :: MonadInterpreter m => String -> m Bool@@ -38,7 +38,7 @@ typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool typeChecks_unsandboxed expr = (typeOf_unsandboxed expr >> return True)- `catchError`+ `catchIE` onCompilationError (\_ -> return False) -- | Returns a string representation of the kind of the type expression.@@ -52,7 +52,7 @@ -- kind <- mayFail $ runGhc1 Compat.typeKind type_expr --- return $ fromGhcRep_ (Compat.Kind kind)+ kindToString (Compat.Kind kind) onCompilationError :: MonadInterpreter m => ([GhcError] -> m a)@@ -60,4 +60,4 @@ onCompilationError recover = \interp_error -> case interp_error of WontCompile errs -> recover errs- otherErr -> throwError otherErr+ otherErr -> throwM otherErr
src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -4,7 +4,8 @@ where -import Control.Monad.CatchIO+import Control.Monad.Trans+import Control.Monad.Catch import Hint.Base import Hint.Configuration@@ -23,7 +24,7 @@ -- context. -- -- Warning: Some options may interact badly with the Interpreter.-unsafeRunInterpreterWithArgs :: (MonadCatchIO m, Functor m)+unsafeRunInterpreterWithArgs :: (MonadCatch m, MonadIO m, Functor m) => [String] -> InterpreterT m a -> m (Either InterpreterError a)
unit-tests/run-unit-tests.hs view
@@ -1,12 +1,11 @@ module Main ( main ) where -import Prelude hiding (catch)+import Prelude -import Control.Exception.Extensible ( ArithException(..), finally )-import Control.Monad.CatchIO ( catch, throw )+import Control.Exception.Extensible ( ArithException(..) )+import Control.Monad.Catch as MC import Control.Monad ( liftM, when )-import Control.Monad.Error ( Error, MonadError(catchError) ) import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar@@ -46,7 +45,8 @@ -- get_f = do loadModules [mod_file] setTopLevelModules [mod_name]- interpret "f" (as :: Int -> Int)+ r <- interpret "f" (as :: Int -> Int)+ return r test_lang_exts :: TestCase test_lang_exts = TestCase "lang_exts" [mod_file] $ do@@ -193,7 +193,7 @@ setImports ["Prelude"] succeeds (action `catch` handler) @@? "catch failed" where handler DivideByZero = return "catched"- handler e = throw e+ handler e = throwM e action = do s <- eval "1 `div` 0 :: Int" return $! s @@ -211,20 +211,21 @@ tests :: [TestCase]-tests = [test_reload_modified,- test_lang_exts,- test_work_in_main,- test_comments_in_expr,- test_qual_import,- test_basic_eval,- test_eval_layout,- test_show_in_scope,- test_installed_not_in_scope,- test_priv_syms_in_scope,- test_search_path,- test_search_path_dot,- test_catch,- test_only_one_instance]+tests = [test_reload_modified+ ,test_lang_exts+ ,test_work_in_main+ ,test_comments_in_expr+ ,test_qual_import+ ,test_basic_eval+ ,test_eval_layout+ ,test_show_in_scope+ ,test_installed_not_in_scope+ ,test_priv_syms_in_scope+ ,test_search_path+ ,test_search_path_dot+ ,test_catch+ ,test_only_one_instance+ ] main :: IO () main = do -- run the tests...@@ -255,10 +256,13 @@ (@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m () m_a @@?= b = do a <- m_a; liftIO (a @?= b) -fails :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool-fails action = (action >> return False) `catchError` (\_ -> return True)+fails :: (MonadCatch m, MonadIO m) => m a -> m Bool+fails action = (action >> return False) `catchIE` (\_ -> return True)+ where+ catchIE :: MonadCatch m => m a -> (InterpreterError -> m a) -> m a+ catchIE = MC.catch -succeeds :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool+succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool succeeds = liftM not . fails