diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +### 0.9.0.3 + +* Support GHC 8.10 +* Drop support for GHC 8.4 +* Hint can now be used concurrently from multiple threads on GHC 8.10+ + ### 0.9.0.2 * Support GHC 8.8 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,19 +3,75 @@ [![Build Status](https://travis-ci.com/haskell-hint/hint.svg?branch=master)](https://travis-ci.com/haskell-hint/hint) [![Hackage](https://img.shields.io/hackage/v/hint.svg)](https://hackage.haskell.org/package/hint) -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). +This library defines an Interpreter monad within which you can interpret +strings like `"[1,2] ++ [3]"` into values like `[1,2,3]`. You can easily +exchange data between your compiled program and your interpreted program, as +long as the data has a `Typeable` instance. -It is, essentially, a huge subset of the GHC API wrapped in a simpler -API. +You can choose which modules should be in scope while evaluating these +expressions, you can browse the contents of those modules, and you can ask for +the type of the identifiers you're browsing. -Compatibility is kept with the three last major GHC releases. For -example, if the current version is GHC 8.6, Hint will work on 8.6, 8.4 -and 8.2. +It is, essentially, a huge subset of the GHC API wrapped in a simpler API. -### Example +## Limitations -Check [example.hs](examples/example.hs) to see a simple but -comprehensive example (it must be run from the `examples` directory). +It is possible to run the interpreter inside a thread, but you can't run two +instances of the interpreter simlutaneously. + +GHC must be installed on the system on which the compiled executable is running. + +Compatibility is kept with the three last major GHC releases. For example, if +the current version is GHC 8.6, `hint` will work on 8.6, 8.4 and 8.2. + +## Example + + {-# LANGUAGE LambdaCase, ScopedTypeVariables, TypeApplications #-} + import Control.Exception (throwIO) + import Control.Monad.Trans.Class (lift) + import Control.Monad.Trans.Writer (execWriterT, tell) + import Data.Foldable (for_) + import Data.Typeable (Typeable) + import qualified Language.Haskell.Interpreter as Hint + + -- | + -- Interpret expressions into values: + -- + -- >>> eval @[Int] "[1,2] ++ [3]" + -- [1,2,3] + -- + -- Send values from your compiled program to your interpreted program by + -- interpreting a function: + -- + -- >>> f <- eval @(Int -> [Int]) "\\x -> [1..x]" + -- >>> f 5 + -- [1,2,3,4,5] + eval :: forall t. Typeable t + => String -> IO t + eval s = runInterpreter $ do + Hint.setImports ["Prelude"] + Hint.interpret s (Hint.as :: t) + + -- | + -- >>> :{ + -- do contents <- browse "Prelude" + -- for_ contents $ \(identifier, tp) -> do + -- when ("put" `isPrefixOf` identifier) $ do + -- putStrLn $ identifier ++ " :: " ++ tp + -- :} + -- putChar :: Char -> IO () + -- putStr :: String -> IO () + -- putStrLn :: String -> IO () + browse :: Hint.ModuleName -> IO [(String, String)] + browse moduleName = runInterpreter $ do + Hint.setImports ["Prelude", "Data.Typeable", moduleName] + exports <- Hint.getModuleExports moduleName + execWriterT $ do + for_ exports $ \case + Hint.Fun identifier -> do + tp <- lift $ Hint.typeOf identifier + tell [(identifier, tp)] + _ -> pure () -- skip datatypes and typeclasses + +Check [example.hs](examples/example.hs) for a longer example (it must be run +from hint's base directory). diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -2,9 +2,11 @@ import Control.Monad import Language.Haskell.Interpreter +import System.Directory main :: IO () -main = do r <- runInterpreter testHint +main = do setCurrentDirectory "examples" + r <- runInterpreter testHint case r of Left err -> putStrLn $ errorString err Right () -> return () @@ -66,7 +68,9 @@ say $ show $ not bool_val emptyLine say "Here we evaluate an expression of type string, that when evaluated (again) leads to a string" - res <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer >>= flip interpret infer + res <- do + s <- interpret "head $ map show [\"Worked!\", \"Didn't work\"]" infer + interpret s infer say res emptyLine say "We can also execute statements in the IO monad and bind new names, e.g." diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.9.0.2 +version: 0.9.0.3 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -40,12 +40,16 @@ HUnit, directory, filepath, - extensible-exceptions, exceptions >= 0.10.0, + stm, -- packages used by setImports calls containers + if impl(ghc >= 8.10) { + cpp-options: -DTHREAD_SAFE_LINKER + } + if !os(windows) { build-depends: unix >= 2.2.0.0 } @@ -54,18 +58,18 @@ library build-depends: base == 4.*, - ghc >= 8.2 && < 8.9, + ghc >= 8.4 && < 8.11, ghc-paths, ghc-boot, - mtl, + transformers, filepath, exceptions == 0.10.*, random, - directory + directory, + temporary - if impl(ghc >= 8.4 && < 8.9) { - build-depends: temporary - cpp-options: -DNEED_PHANTOM_DIRECTORY + if impl(ghc >= 8.10) { + cpp-options: -DTHREAD_SAFE_LINKER } if !os(windows) { @@ -103,3 +107,4 @@ Rank2Types ScopedTypeVariables ExistentialQuantification + LambdaCase diff --git a/src/Control/Monad/Ghc.hs b/src/Control/Monad/Ghc.hs --- a/src/Control/Monad/Ghc.hs +++ b/src/Control/Monad/Ghc.hs @@ -6,8 +6,8 @@ import Prelude import Control.Monad -import Control.Monad.Trans -import qualified Control.Monad.Trans as MTL +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Catch @@ -40,10 +40,10 @@ runGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a runGhcT f = unMTLA . rawRunGhcT f . unGhcT -instance MTL.MonadTrans GhcT where +instance MonadTrans GhcT where lift = GhcT . GHC.liftGhcT . MTLAdapter -instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where +instance MonadIO m => MonadIO (GhcT m) where liftIO = GhcT . GHC.liftIO instance MonadCatch m => MonadThrow (GhcT m) where @@ -87,8 +87,8 @@ -- like 'MTL'''s 'MonadIO' and 'GHC'''s 'MonadIO'. newtype MTLAdapter m a = MTLAdapter {unMTLA :: m a} deriving (Functor, Applicative, Monad) -instance MTL.MonadIO m => GHC.MonadIO (MTLAdapter m) where - liftIO = MTLAdapter . MTL.liftIO +instance MonadIO m => GHC.MonadIO (MTLAdapter m) where + liftIO = MTLAdapter . liftIO instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (MTLAdapter m) where m `gcatch` f = MTLAdapter $ unMTLA m `catch` (unMTLA . f) diff --git a/src/Hint/Annotations.hs b/src/Hint/Annotations.hs --- a/src/Hint/Annotations.hs +++ b/src/Hint/Annotations.hs @@ -6,6 +6,7 @@ import Data.Data import Annotations import GHC.Serialized +import MonadUtils (concatMapM) import Hint.Base import HscTypes (hsc_mod_graph, ms_mod) @@ -14,17 +15,15 @@ -- Get the annotations associated with a particular module. getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getModuleAnnotations _ x = do - mods <- fmap (GHC.mgModSummaries . hsc_mod_graph) $ runGhc GHC.getSession + mods <- GHC.mgModSummaries . hsc_mod_graph <$> runGhc GHC.getSession let x' = filter ((==) x . GHC.moduleNameString . GHC.moduleName . ms_mod) mods - v <- mapM (anns . ModuleTarget . ms_mod) x' - return $ concat v + concatMapM (anns . ModuleTarget . ms_mod) x' -- Get the annotations associated with a particular function. getValAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] -getValAnnotations _ x = do - x' <- runGhc1 GHC.parseName x - v <- mapM (anns . NamedTarget) x' - return $ concat v +getValAnnotations _ s = do + names <- runGhc1 GHC.parseName s + concatMapM (anns . NamedTarget) names anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a] anns = runGhc1 (GHC.findGlobalAnns deserializeWithData) diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -19,7 +19,7 @@ debug, showGHC ) where -import Control.Monad.Trans +import Control.Monad.IO.Class import Control.Monad.Catch as MC import Data.IORef @@ -60,9 +60,7 @@ data InterpreterState = St { activePhantoms :: [PhantomModule], zombiePhantoms :: [PhantomModule], -#if defined(NEED_PHANTOM_DIRECTORY) phantomDirectory :: Maybe FilePath, -#endif hintSupportModule :: PhantomModule, importQualHackMod :: Maybe PhantomModule, qualImports :: [ModuleImport], @@ -151,11 +149,12 @@ -- ================ Handling the interpreter state ================= fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a -fromState f = do ref_st <- fromSession internalState - liftIO $ f `fmap` readIORef ref_st +fromState f = do + ref_st <- fromSession internalState + liftIO $ f <$> readIORef ref_st onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m () -onState f = modifySessionRef internalState f >> return () +onState f = () <$ modifySessionRef internalState f -- =============== Error handling ============================== @@ -194,13 +193,13 @@ where mod_name = GHC.mkModuleName mn moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool -moduleIsLoaded mn = (findModule mn >> return True) +moduleIsLoaded mn = (True <$ findModule mn) `catchIE` (\e -> case e of NotAllowed{} -> return False WontCompile{} -> return False _ -> throwM e) withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a -withDynFlags action - = do df <- runGhc GHC.getSessionDynFlags - action df +withDynFlags action = do + df <- runGhc GHC.getSessionDynFlags + action df diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -17,9 +17,7 @@ import Control.Monad import Control.Monad.Catch import Data.Char -#if defined(NEED_PHANTOM_DIRECTORY) import Data.Maybe (maybe) -#endif import Data.List (intercalate) import qualified Hint.GHC as GHC @@ -86,7 +84,7 @@ getter = fromConf languageExts -- resetExtensions = do es <- fromState defaultExts - setGhcOptions $ map (uncurry $ flip extFlag) es + setGhcOptions $ uncurry (flip extFlag) <$> es extFlag :: Bool -> Extension -> String extFlag = mkFlag @@ -124,11 +122,10 @@ setter p = do onConf $ \c -> c{searchFilePath = p} setGhcOption "-i" -- clear the old path setGhcOption $ "-i" ++ intercalate ":" p -#if defined(NEED_PHANTOM_DIRECTORY) + mfp <- fromState phantomDirectory maybe (return ()) (\fp -> setGhcOption $ "-i" ++ fp) mfp -#endif fromConf :: MonadInterpreter m => (InterpreterConfiguration -> a) -> m a fromConf f = fromState (f . configuration) diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -18,8 +18,8 @@ import Control.Arrow ((***)) -import Control.Monad (liftM, filterM, unless, guard, foldM, (>=>)) -import Control.Monad.Trans (liftIO) +import Control.Monad (filterM, unless, guard, foldM) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Catch import Hint.Base @@ -32,11 +32,9 @@ import System.FilePath import System.Directory -#if defined(NEED_PHANTOM_DIRECTORY) import Data.Maybe (maybe) import Hint.Configuration (setGhcOption) import System.IO.Temp -#endif type ModuleText = String @@ -62,7 +60,6 @@ getPhantomDirectory :: MonadInterpreter m => m FilePath getPhantomDirectory = -#if defined(NEED_PHANTOM_DIRECTORY) -- When a module is loaded by file name, ghc-8.4.1 loses track of the -- file location after the first time it has been loaded, so we create -- a directory for the phantom modules and add it to the search path. @@ -74,15 +71,14 @@ onState (\s -> s{ phantomDirectory = Just fp }) setGhcOption $ "-i" ++ fp return fp -#else - liftIO getTemporaryDirectory -#endif allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc getContextNames getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) -getContext = GHC.getContext >>= foldM f ([], []) +getContext = do + ctx <- GHC.getContext + foldM f ([], []) ctx where f :: (GHC.GhcMonad m) => ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) -> @@ -90,15 +86,11 @@ m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) f (ns, ds) i = case i of (GHC.IIDecl d) -> return (ns, d : ds) - m@(GHC.IIModule _) -> do n <- iiModToMod m; return (n : ns, ds) + (GHC.IIModule m) -> do n <- GHC.findModule m Nothing; return (n : ns, ds) modToIIMod :: GHC.Module -> GHC.InteractiveImport modToIIMod = GHC.IIModule . GHC.moduleName -iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module -iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing -iiModToMod _ = error "iiModToMod!" - getContextNames :: GHC.GhcMonad m => m([String], [String]) getContextNames = fmap (map name *** map decl) getContext where name = GHC.moduleNameString . GHC.moduleName @@ -149,7 +141,7 @@ -- return pm -removePhantomModule :: MonadInterpreter m => PhantomModule -> m () +removePhantomModule :: forall m. MonadInterpreter m => PhantomModule -> m () removePhantomModule pm = do -- We don't want to actually unload this module, because that -- would mean that all the real modules might get reloaded and the @@ -168,9 +160,10 @@ let mods' = filter (mod /=) mods runGhc2 setContext mods' imps -- - let isNotPhantom = isPhantomModule . moduleToString >=> - return . not - null `liftM` filterM isNotPhantom mods' + let isNotPhantom :: GHC.Module -> m Bool + isNotPhantom mod' = do + not <$> isPhantomModule (moduleToString mod') + null <$> filterM isNotPhantom mods' else return True -- let file_name = pmFile pm @@ -235,22 +228,24 @@ -- | Returns True if the module was interpreted. isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool -isModuleInterpreted m = findModule m >>= runGhc1 GHC.moduleIsInterpreted +isModuleInterpreted moduleName = do + mod <- findModule moduleName + runGhc1 GHC.moduleIsInterpreted mod -- | Returns the list of modules loaded with 'loadModules'. getLoadedModules :: MonadInterpreter m => m [ModuleName] getLoadedModules = do (active_pms, zombie_pms) <- getPhantomModules - ms <- map modNameFromSummary `liftM` getLoadedModSummaries + ms <- map modNameFromSummary <$> getLoadedModSummaries return $ ms \\ map pmName (active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName modNameFromSummary = moduleToString . GHC.ms_mod getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary] -getLoadedModSummaries = - do all_mod_summ <- runGhc GHC.getModuleGraph - filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) - (GHC.mgModSummaries all_mod_summ) +getLoadedModSummaries = do + modGraph <- runGhc GHC.getModuleGraph + let modSummaries = GHC.mgModSummaries modGraph + filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) modSummaries -- | Sets the modules whose context is used during evaluation. All bindings -- of these modules are in scope, not only those exported. @@ -302,32 +297,41 @@ -- @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@ setImportsF :: MonadInterpreter m => [ModuleImport] -> m () -setImportsF ms = do +setImportsF moduleImports = do regularMods <- mapM (findModule . modName) regularImports mapM_ (findModule . modName) phantomImports -- just to be sure they exist -- old_qual_hack_mod <- fromState importQualHackMod maybe (return ()) removePhantomModule old_qual_hack_mod -- - new_pm <- if null phantomImports - then return Nothing - else do - new_pm <- addPhantomModule $ \mod_name -> unlines $ - ("module " ++ mod_name ++ " where ") : - map newImportLine phantomImports - onState (\s -> s{importQualHackMod = Just new_pm}) - return $ Just new_pm + maybe_phantom_module <- do + if null phantomImports + then return Nothing + else do + let moduleContents = map newImportLine phantomImports + new_phantom_module <- addPhantomModule $ \mod_name + -> unlines $ ("module " ++ mod_name ++ " where ") + : moduleContents + onState (\s -> s{importQualHackMod = Just new_phantom_module}) + return $ Just new_phantom_module -- - pm <- maybe (return []) (findModule . pmName >=> return . return) new_pm + phantom_mods <- case maybe_phantom_module of + Nothing -> do + pure [] + Just phantom_module-> do + phantom_mod <- findModule (pmName phantom_module) + pure [phantom_mod] (old_top_level, _) <- runGhc getContext - let new_top_level = pm ++ old_top_level + let new_top_level = phantom_mods ++ old_top_level runGhc2 setContextModules new_top_level regularMods -- onState (\s ->s{qualImports = phantomImports}) where - (regularImports, phantomImports) = partitionEithers $ map (\m -> if isQualified m || hasImportList m - then Right m - else Left m) ms + (regularImports, phantomImports) = partitionEithers + $ map (\m -> if isQualified m || hasImportList m + then Right m -- phantom + else Left m) + moduleImports isQualified m = modQual m /= NotQualified hasImportList m = modImp m /= NoImportList newImportLine m = concat ["import ", case modQual m of @@ -367,11 +371,10 @@ importQualHackMod = Nothing, qualImports = []}) liftIO $ mapM_ (removeFile . pmFile) (old_active ++ old_zombie) -#if defined(NEED_PHANTOM_DIRECTORY) + old_phantomdir <- fromState phantomDirectory onState (\s -> s{phantomDirectory = Nothing}) liftIO $ do maybe (return ()) removeDirectory old_phantomdir -#endif -- | All imported modules are cleared from the context, and -- loaded modules are unloaded. It is similar to a @:load@ in diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs --- a/src/Hint/Eval.hs +++ b/src/Hint/Eval.hs @@ -9,8 +9,8 @@ import Control.Exception -import Data.Typeable hiding (typeOf) -import qualified Data.Typeable (typeOf) +import Data.Typeable (Typeable) +import qualified Data.Typeable as Typeable import Hint.Base import Hint.Context @@ -31,7 +31,7 @@ -- | Evaluates an expression, given a witness for its monomorphic type. interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a -interpret expr wit = unsafeInterpret expr (show $ Data.Typeable.typeOf wit) +interpret expr wit = unsafeInterpret expr (show $ Typeable.typeOf wit) unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a unsafeInterpret expr type_str = diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -1,46 +1,39 @@ module Hint.GHC ( - Message, module X, -#if __GLASGOW_HASKELL__ < 804 - GhcPs, mgModSummaries -#endif + Message, module X ) where import GHC as X hiding (Phase, GhcT, runGhcT) import Control.Monad.Ghc as X (GhcT, runGhcT) import HscTypes as X (SourceError, srcErrorMessages, GhcApiError) -#if __GLASGOW_HASKELL__ >= 804 import HscTypes as X (mgModSummaries) -#endif import Outputable as X (PprStyle, SDoc, Outputable(ppr), showSDoc, showSDocForUser, showSDocUnqual, - withPprStyle, defaultErrStyle) + withPprStyle, defaultErrStyle, vcat) -import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc) -- we alias MsgDoc as Message below +import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc +#if __GLASGOW_HASKELL__ >= 810 + , errMsgSpan, pprErrMsgBagWithLoc +#endif + ) -- we alias MsgDoc as Message below import DriverPhases as X (Phase(Cpp), HscSource(HsSrcFile)) import StringBuffer as X (stringToStringBuffer) -import Lexer as X (P(..), ParseResult(..), mkPState) +import Lexer as X (P(..), ParseResult(..), mkPState +#if __GLASGOW_HASKELL__ >= 810 + , getErrorMessages +#endif + ) import Parser as X (parseStmt, parseType) import FastString as X (fsLit) -import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..)) - -import DynFlags as X (WarnReason(NoReason)) +import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..), + WarnReason(NoReason), addWay', Way(..), dynamicGhc) import PprTyThing as X (pprTypeForUser) -import SrcLoc as X (mkRealSrcLoc) +import SrcLoc as X (combineSrcSpans, mkRealSrcLoc) import ConLike as X (ConLike(RealDataCon)) -import DynFlags as X (addWay', Way(..), dynamicGhc) - type Message = MsgDoc - -#if __GLASGOW_HASKELL__ < 804 -type GhcPs = RdrName - -mgModSummaries :: ModuleGraph -> [ModSummary] -mgModSummaries = id -#endif diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -12,7 +12,10 @@ import Hint.Configuration import Hint.Extension -import Control.Monad.Reader +import Control.Monad (ap, unless) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader import Control.Monad.Catch as MC import Data.Typeable (Typeable) @@ -88,7 +91,9 @@ -- available; calling this function once is mandatory! _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler} - let extMap = map (\fs -> (GHC.flagSpecName fs, GHC.flagSpecFlag fs)) GHC.xFlags + let extMap = [ (GHC.flagSpecName flagSpec, GHC.flagSpecFlag flagSpec) + | flagSpec <- GHC.xFlags + ] let toOpt e = let err = error ("init error: unknown ext:" ++ show e) in fromMaybe err (lookup e extMap) let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2) @@ -123,23 +128,25 @@ -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgsLibdir args libdir action = +#ifndef THREAD_SAFE_LINKER ifInterpreterNotRunning $ +#endif do s <- newInterpreterSession `MC.catch` rethrowGhcException execute libdir s (initialize args >> action `finally` cleanSession) where rethrowGhcException = throwM . GhcException . showGhcEx newInterpreterSession = newSessionData () cleanSession = cleanPhantomModules +#ifndef THREAD_SAFE_LINKER {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () uniqueToken = unsafePerformIO $ newMVar () ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a -ifInterpreterNotRunning action = - do maybe_token <- liftIO $ tryTakeMVar uniqueToken - case maybe_token of - Nothing -> throwM MultipleInstancesNotAllowed - Just x -> action `finally` liftIO (putMVar uniqueToken x) +ifInterpreterNotRunning action = liftIO (tryTakeMVar uniqueToken) >>= \ case + Nothing -> throwM MultipleInstancesNotAllowed + Just x -> action `finally` liftIO (putMVar uniqueToken x) +#endif -- | The installed version of ghc is not thread-safe. This exception -- is thrown whenever you try to execute @runInterpreter@ while another @@ -156,9 +163,7 @@ initialState = St { activePhantoms = [], zombiePhantoms = [], -#if defined(NEED_PHANTOM_DIRECTORY) phantomDirectory = Nothing, -#endif hintSupportModule = error "No support module loaded!", importQualHackMod = Nothing, qualImports = [], diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -4,7 +4,7 @@ import Hint.Base -import Control.Monad.Trans (liftIO) +import Control.Monad.IO.Class (liftIO) import qualified Hint.GHC as GHC @@ -29,25 +29,25 @@ case parse_res of GHC.POk{} -> return ParseOk -- -#if __GLASGOW_HASKELL__ >= 804 - GHC.PFailed _ span err +#if __GLASGOW_HASKELL__ >= 810 + GHC.PFailed pst -> let errMsgs = GHC.getErrorMessages pst dyn_fl + span = foldr (GHC.combineSrcSpans . GHC.errMsgSpan) GHC.noSrcSpan errMsgs + err = GHC.vcat $ GHC.pprErrMsgBagWithLoc errMsgs + in pure (ParseError span err) #else - GHC.PFailed span err -#endif + GHC.PFailed _ span err -> return (ParseError span err) +#endif failOnParseError :: MonadInterpreter m => (String -> m ParseResult) -> String -> m () failOnParseError parser expr = mayFail go - where go = do parsed <- parser expr - -- - -- If there was a parsing error, - -- do the "standard" error reporting - case parsed of + where go = parser expr >>= \ case ParseOk -> return (Just ()) - -- + -- If there was a parsing error, + -- do the "standard" error reporting ParseError span err -> do -- parsing failed, so we report it just as all -- other errors get reported.... diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -38,30 +38,18 @@ asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem] asModElemList df xs = concat [ - cs', - ts', - ds \\ concatMap (map Fun . children) ts', - fs \\ concatMap (map Fun . children) cs' + cs, + ts, + ds \\ concatMap (map Fun . children) ts, + fs \\ concatMap (map Fun . children) cs ] - where (cs,ts,ds,fs) = - ( - [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], - [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], - [asModElem df d | d@(GHC.AConLike GHC.RealDataCon{}) <- xs], - [asModElem df f | f@GHC.AnId{} <- xs] - ) - cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs] - ts' = [Data t $ filter (alsoIn ds) dcs | Data t dcs <- ts] + where cs = [Class (getUnqualName df tc) (filter (alsoIn fs) $ getUnqualName df <$> GHC.classMethods c) + | GHC.ATyCon tc <- xs, Just c <- [GHC.tyConClass_maybe tc]] + ts = [Data (getUnqualName df tc) (filter (alsoIn ds) $ getUnqualName df <$> GHC.tyConDataCons tc) + | GHC.ATyCon tc <- xs, Nothing <- [GHC.tyConClass_maybe tc]] + ds = [Fun $ getUnqualName df dc | GHC.AConLike (GHC.RealDataCon dc) <- xs] + fs = [Fun $ getUnqualName df f | GHC.AnId f <- xs] alsoIn es = (`elem` map name es) - -asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem -asModElem df (GHC.AnId f) = Fun $ getUnqualName df f -asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc -asModElem df (GHC.ATyCon tc) = - if GHC.isClassTyCon tc - then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc) - else Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc) -asModElem _ _ = error "asModElem: can't happen!" getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String getUnqualName dfs = GHC.showSDocUnqual dfs . GHC.pprParenSymName diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs --- a/src/Hint/Typecheck.hs +++ b/src/Hint/Typecheck.hs @@ -18,9 +18,8 @@ -- kind of errors failOnParseError parseExpr expr -- - ty <- mayFail $ runGhc1 exprType expr - -- - typeToString ty + type_ <- mayFail (runGhc1 exprType expr) + typeToString type_ -- | Tests if the expression type checks. -- @@ -28,7 +27,7 @@ -- Perhaps unsurprisingly, that can falsely make @typeChecks@ and @getType@ -- return @True@ and @Right _@ respectively. typeChecks :: MonadInterpreter m => String -> m Bool -typeChecks expr = (typeOf expr >> return True) +typeChecks expr = (True <$ typeOf expr) `catchIE` onCompilationError (\_ -> return False) diff --git a/src/Language/Haskell/Interpreter.hs b/src/Language/Haskell/Interpreter.hs --- a/src/Language/Haskell/Interpreter.hs +++ b/src/Language/Haskell/Interpreter.hs @@ -43,7 +43,8 @@ InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous ghcVersion, parens, - module Control.Monad.Trans + module Control.Monad.Trans.Class, + module Control.Monad.IO.Class, ) where import Hint.Base @@ -55,4 +56,5 @@ import Hint.Typecheck import Hint.Eval -import Control.Monad.Trans +import Control.Monad.IO.Class +import Control.Monad.Trans.Class diff --git a/src/Language/Haskell/Interpreter/Unsafe.hs b/src/Language/Haskell/Interpreter/Unsafe.hs --- a/src/Language/Haskell/Interpreter/Unsafe.hs +++ b/src/Language/Haskell/Interpreter/Unsafe.hs @@ -3,7 +3,7 @@ unsafeInterpret ) where -import Control.Monad.Trans +import Control.Monad.IO.Class import Control.Monad.Catch import Hint.Base @@ -35,7 +35,7 @@ -- containers, etc.) can be found. This allows you to run hint on -- a machine in which GHC is not installed. -- --- A typical libdir value could be "/usr/lib/ghc-8.0.1/ghc-8.0.1". +-- A typical libdir value could be @/usr/lib/ghc-8.0.1/ghc-8.0.1@. unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m) => [String] -> String 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 @@ -2,13 +2,14 @@ import Prelude hiding (catch) -import Control.Exception.Extensible (ArithException(..), AsyncException(UserInterrupt)) +import Control.Exception (ArithException(..), AsyncException(UserInterrupt)) import Control.Monad.Catch as MC -import Control.Monad (liftM, when, void, (>=>)) +import Control.Monad (guard, liftM, when, void, (>=>)) import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar +import Control.Concurrent.STM import Data.IORef @@ -21,7 +22,7 @@ import System.Posix.Signals #endif -import Test.HUnit ((@?=), (@?)) +import Test.HUnit ((@?=), (@?), assertFailure) import qualified Test.HUnit as HUnit import Language.Haskell.Interpreter @@ -204,6 +205,13 @@ action = do s <- eval "1 `div` 0 :: Int" return $! s +#ifndef THREAD_SAFE_LINKER +-- Prior to ghc-8.10, the linker wasn't thread-safe, and so running multiple +-- instances of hint in different threads can lead to mysterious errors of the +-- form "Could not load '*_closure', dependency unresolved". To make that error +-- less mysterious, 'ifInterpreterNotRunning' throw a clearer error earlier, as +-- soon as it detects that the user is trying to run multiple instances of hint +-- in parallel. This test ensures that this nicer error is thrown. test_only_one_instance :: TestCase test_only_one_instance = TestCase "only_one_instance" [] $ liftIO $ do r <- newEmptyMVar @@ -213,7 +221,60 @@ return $ Right () _ <- forkIO $ Control.Monad.void concurrent readMVar r @? "concurrent instance did not fail" +#else +-- Prior to ghc-8.10, the linker wasn't thread-safe, and so running multiple +-- instances of hint in different threads can lead to mysterious errors of the +-- form "Could not load '*_closure', dependency unresolved". This test ensures +-- that this error no longer occurs. The important thing about this test is +-- that it should _fail_ if 'ifInterpreterNotRunning' is deleted and this test +-- is run on an older ghc version. Otherwise this test is not testing what it's +-- meant to. +test_multiple_instances :: TestCase +test_multiple_instances = TestCase "multiple_instances" ["mod_file"] $ liftIO $ do + writeFile mod_file "f = id" + -- ensure the two threads interleave in a deterministic way + tvar <- newTVarIO 1 + let step n = liftIO $ atomically $ do + nextStep <- readTVar tvar + guard (nextStep >= n) + writeTVar tvar (n + 1) + skipToStep n = liftIO $ atomically $ do + modifyTVar tvar (max n) + + mvar1 <- newEmptyMVar + mvar2 <- newEmptyMVar + void $ forkIO $ do + r1 <- try $ runInterpreter $ do + step 1 + loadModules [mod_file] + step 3 + setTopLevelModules ["Main"] + step 5 + setImports ["Prelude"] + step 7 + eval "f [1,2]" @@?= "[1,2]" + step 9 + skipToStep 9 + putMVar mvar1 r1 + void $ forkIO $ do + r2 <- try $ runInterpreter $ do + step 2 + loadModules [mod_file] + step 4 + setTopLevelModules ["Main"] + step 6 + setImports ["Prelude"] + step 8 + eval "f [1,2]" @@?= "[1,2]" + step 10 + skipToStep 10 + putMVar mvar2 r2 + noInterpreterError =<< noExceptions =<< takeMVar mvar1 + noInterpreterError =<< noExceptions =<< takeMVar mvar2 + where mod_file = "TEST_MultipleInstances.hs" +#endif + test_normalize_type :: TestCase test_normalize_type = TestCase "normalize_type" [mod_file] $ do liftIO $ writeFile mod_file mod_text @@ -283,7 +344,11 @@ ,test_search_path ,test_search_path_dot ,test_catch +#ifndef THREAD_SAFE_LINKER ,test_only_one_instance +#else + ,test_multiple_instances +#endif ,test_normalize_type ] @@ -330,6 +395,14 @@ succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool succeeds = fmap not . fails +noExceptions :: Either SomeException a -> IO a +noExceptions (Left e) = assertFailure (show e) +noExceptions (Right a) = pure a + +noInterpreterError :: Either InterpreterError a -> IO a +noInterpreterError (Left e) = assertFailure (show e) +noInterpreterError (Right a) = pure a + data IOTestCase = IOTestCase String [FilePath] ((Interpreter () -> IO (Either InterpreterError ())) -> IO (Either InterpreterError ())) runIOTests :: Bool -> [IOTestCase] -> IO HUnit.Counts @@ -340,8 +413,7 @@ clean_up = mapM_ removeIfExists tmps go = do r <- test (\body -> runInterpreter (when sandboxed setSandbox >> body)) - either (printInterpreterError >=> (fail . show)) - return r + noInterpreterError r removeIfExists f = do existsF <- doesFileExist f if existsF then removeFile f