packages feed

hint 0.9.0.2 → 0.9.0.3

raw patch · 18 files changed

+298/−170 lines, 18 filesdep +stmdep +transformersdep −extensible-exceptionsdep −mtldep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: stm, transformers

Dependencies removed: extensible-exceptions, mtl

Dependency ranges changed: ghc

API changes (from Hackage documentation)

Files

CHANGELOG.md view
@@ -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
README.md view
@@ -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).
examples/example.hs view
@@ -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."
hint.cabal view
@@ -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
src/Control/Monad/Ghc.hs view
@@ -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)
src/Hint/Annotations.hs view
@@ -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)
src/Hint/Base.hs view
@@ -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
src/Hint/Configuration.hs view
@@ -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)
src/Hint/Context.hs view
@@ -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
src/Hint/Eval.hs view
@@ -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 =
src/Hint/GHC.hs view
@@ -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
src/Hint/InterpreterT.hs view
@@ -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       = [],
src/Hint/Parsers.hs view
@@ -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....
src/Hint/Reflection.hs view
@@ -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
src/Hint/Typecheck.hs view
@@ -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)
src/Language/Haskell/Interpreter.hs view
@@ -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
src/Language/Haskell/Interpreter/Unsafe.hs view
@@ -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
unit-tests/run-unit-tests.hs view
@@ -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