diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -12,6 +12,7 @@ Evan Laforge Fernando Benavides Gwern Branwen +Heinrich Apfelmus Jean Philippe Bernardy Jens Petersen Mark Wright diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +### 0.8.0 + +* Support GHC 8.4 +* Drop support for GHC 7.8 and 7.10 +* Add `runStmt` to execute statements in the IO monad and bind new names +* Internal changes of temporary files for phantom modules + - The files are now called `M.hs` instead of `` + - Improved cleanup of phantom module source files + - ghc 8.4 only: phantom modules are put into a temporary directory +* Add `typeChecksWithDetails` to obtain type-checking errors +* Stop GHC from overwriting the Ctrl-C signal handler +* Add `SetImportsF` to allow finer imports control + ### 0.7.0 * Support for GHC 8.2 @@ -128,7 +141,7 @@ * Exports functions parens and isInterpretedModule * Experimental support for module annotations * Uses extensible-exceptions in order to provide a uniform interface - accross different ghc versions + across different ghc versions * Provides an Applicative instance for IntepreterT * Adds an option to configurate the searchPath diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,6 +11,10 @@ It is, essentially, a huge subset of the GHC API wrapped in a simpler API. +Compatibility is kept with the three last major GHC releases. For +example, if the current version is GHC 8.4, Hint will work on 8.4, 8.2 +and 8.0. + ### Example Check [example.hs](examples/example.hs) to see a simple but diff --git a/examples/example.hs b/examples/example.hs --- a/examples/example.hs +++ b/examples/example.hs @@ -68,3 +68,10 @@ 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 say res + emptyLine + say "We can also execute statements in the IO monad and bind new names, e.g." + let stmts = ["x <- return 42", "print x"] + forM_ stmts $ \s -> do + say $ " " ++ s + runStmt s + emptyLine diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.7.0 +version: 0.8.0 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -41,18 +41,30 @@ directory, filepath, extensible-exceptions, - exceptions + exceptions >= 0.10.0 + if !os(windows) { + build-depends: unix >= 2.2.0.0 + } + + extensions: CPP + library build-depends: base == 4.*, - ghc >= 7.6 && < 8.4, + ghc >= 8.0 && < 8.6, ghc-paths, + ghc-boot, mtl, filepath, - exceptions, + exceptions == 0.10.*, random, directory + if impl(ghc >= 8.4 && < 8.6) { + build-depends: temporary + cpp-options: -DNEED_PHANTOM_DIRECTORY + } + if !os(windows) { build-depends: unix >= 2.2.0.0 } @@ -60,6 +72,7 @@ exposed-modules: Language.Haskell.Interpreter Language.Haskell.Interpreter.Extension Language.Haskell.Interpreter.Unsafe + Hint.Internal other-modules: Hint.GHC Hint.Base Hint.InterpreterT 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 @@ -11,7 +11,9 @@ import Control.Monad.Catch -import qualified GHC (runGhcT) +import Data.IORef + +import qualified GHC import qualified MonadUtils as GHC import qualified Exception as GHC import qualified GhcMonad as GHC @@ -25,12 +27,18 @@ pure = return (<*>) = ap -#if __GLASGOW_HASKELL__ >= 800 +-- adapted from https://github.com/ghc/ghc/blob/ghc-8.2/compiler/main/GHC.hs#L450-L459 +-- modified to _not_ catch ^C +rawRunGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GHC.GhcT (MTLAdapter m) a -> MTLAdapter m a +rawRunGhcT mb_top_dir ghct = do + ref <- liftIO $ newIORef (error "empty session") + let session = GHC.Session ref + flip GHC.unGhcT session $ {-GHC.withSignalHandlers $-} do -- do _not_ catch ^C + GHC.initGhcMonad mb_top_dir + GHC.withCleanupSession ghct + runGhcT :: (MonadIO m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a -#else -runGhcT :: (Functor m, MonadIO m, MonadCatch m, MonadMask m) => Maybe FilePath -> GhcT m a -> m a -#endif -runGhcT f = unMTLA . GHC.runGhcT f . unGhcT +runGhcT f = unMTLA . rawRunGhcT f . unGhcT instance MTL.MonadTrans GhcT where lift = GhcT . GHC.liftGhcT . MTLAdapter @@ -52,7 +60,20 @@ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s) unwrap m = unMTLA . GHC.unGhcT (unGhcT m) - uninterruptibleMask = mask + uninterruptibleMask f = wrap $ \s -> + uninterruptibleMask $ \io_restore -> + unwrap (f $ \m -> (wrap $ \s' -> io_restore (unwrap m s'))) s + where + wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s) + unwrap m = unMTLA . GHC.unGhcT (unGhcT m) + + generalBracket acquire release body + = wrap $ \s -> generalBracket (unwrap acquire s) + (\a exitCase -> unwrap (release a exitCase) s) + (\a -> unwrap (body a) s) + where + wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s) + unwrap m = unMTLA . GHC.unGhcT (unGhcT m) instance (MonadIO m, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (GhcT m) where gcatch = catch diff --git a/src/Hint/Annotations.hs b/src/Hint/Annotations.hs --- a/src/Hint/Annotations.hs +++ b/src/Hint/Annotations.hs @@ -6,7 +6,7 @@ import Control.Monad import Data.Data import Annotations -import Serialized +import GHC.Serialized import Hint.Base import HscTypes (hsc_mod_graph, ms_mod) @@ -15,7 +15,7 @@ -- Get the annotations associated with a particular module. getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getModuleAnnotations _ x = do - mods <- liftM hsc_mod_graph $ runGhc GHC.getSession + mods <- liftM (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 diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -6,6 +6,7 @@ InterpreterSession, SessionData(..), GhcErrLogger, InterpreterState(..), fromState, onState, InterpreterConfiguration(..), + ImportList(..), ModuleQualification(..), ModuleImport(..), runGhc1, runGhc2, @@ -23,20 +24,17 @@ import Data.IORef import Data.Dynamic +import qualified Data.List import qualified Hint.GHC as GHC -#if MIN_VERSION_base(4,8,0) -import qualified Data.List -#endif - import Hint.Extension -- | Version of the underlying ghc api. Values are: -- --- * @710@ for GHC 7.10.x +-- * @802@ for GHC 8.2.x -- --- * @800@ for GHC 8.0.x +-- * @804@ for GHC 8.4.x -- -- * etc... ghcVersion :: Int @@ -62,13 +60,28 @@ data InterpreterState = St { activePhantoms :: [PhantomModule], zombiePhantoms :: [PhantomModule], +#if defined(NEED_PHANTOM_DIRECTORY) + phantomDirectory :: Maybe FilePath, +#endif hintSupportModule :: PhantomModule, importQualHackMod :: Maybe PhantomModule, - qualImports :: [(ModuleName, String)], + qualImports :: [ModuleImport], defaultExts :: [(Extension, Bool)], -- R/O configuration :: InterpreterConfiguration } +data ImportList = NoImportList | ImportList [String] | HidingList [String] + deriving (Eq, Show) +data ModuleQualification = NotQualified | ImportAs String | QualifiedAs (Maybe String) + deriving (Eq, Show) + +-- | Represent module import statement. +-- See 'setImportsF' +data ModuleImport = ModuleImport { modName :: String + , modQual :: ModuleQualification + , modImp :: ImportList + } deriving (Show) + data InterpreterConfiguration = Conf { searchFilePath :: [FilePath], languageExts :: [Extension], @@ -78,36 +91,22 @@ type InterpreterSession = SessionData () instance Exception InterpreterError -#if MIN_VERSION_base(4,8,0) where displayException (UnknownError err) = "UnknownError: " ++ err displayException (WontCompile es) = unlines . Data.List.nub . map errMsg $ es displayException (NotAllowed err) = "NotAllowed: " ++ err displayException (GhcException err) = "GhcException: " ++ err -#endif type RunGhc m a = -#if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a) -#else - (forall n.(MonadIO n, MonadMask n, Functor n) => GHC.GhcT n a) -#endif -> m a type RunGhc1 m a b = -#if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b) -#else - (forall n.(MonadIO n, MonadMask n, Functor n) => a -> GHC.GhcT n b) -#endif -> (a -> m b) type RunGhc2 m a b c = -#if __GLASGOW_HASKELL__ >= 800 (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c) -#else - (forall n.(MonadIO n, MonadMask n, Functor n) => a -> b -> GHC.GhcT n c) -#endif -> (a -> b -> m c) data SessionData a = SessionData { @@ -197,8 +196,9 @@ moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool moduleIsLoaded mn = (findModule mn >> return True) `catchIE` (\e -> case e of - NotAllowed{} -> return False - _ -> throwM e) + NotAllowed{} -> return False + WontCompile{} -> return False + _ -> throwM e) withDynFlags :: MonadInterpreter m => (GHC.DynFlags -> m a) -> m a withDynFlags action diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -17,6 +17,9 @@ 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 @@ -121,6 +124,11 @@ 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 @@ -1,7 +1,7 @@ module Hint.Context ( isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, - setImports, setImportsQ, + setImports, setImportsQ, setImportsF, reset, PhantomModule(..), @@ -13,6 +13,7 @@ import Prelude hiding (mod) import Data.Char +import Data.Either (partitionEithers) import Data.List import Control.Arrow ((***)) @@ -23,7 +24,6 @@ import Hint.Base import Hint.Conversions -import qualified Hint.Util as Util import qualified Hint.CompatPlatform as Compat import qualified Hint.GHC as GHC @@ -32,6 +32,12 @@ 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 -- When creating a phantom module we have a situation similar to that of @@ -50,20 +56,38 @@ let nums = concat [show (abs n::Int), show p, filter isDigit $ concat (ls ++ is)] let mod_name = 'M':nums -- - tmp_dir <- liftIO getTemporaryDirectory + tmp_dir <- getPhantomDirectory -- - return PhantomModule{pmName = mod_name, pmFile = tmp_dir nums} + return PhantomModule{pmName = mod_name, pmFile = tmp_dir mod_name <.> "hs"} +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. + do mfp <- fromState phantomDirectory + case mfp of + Just fp -> return fp + Nothing -> do tmp_dir <- liftIO getTemporaryDirectory + fp <- liftIO $ createTempDirectory tmp_dir "hint" + onState (\s -> s{ phantomDirectory = Just fp }) + setGhcOption $ "-i" ++ fp + return fp +#else + do liftIO getTemporaryDirectory +#endif + allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc getContextNames -getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) +getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) getContext = GHC.getContext >>= foldM f ([], []) where f :: (GHC.GhcMonad m) => - ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) -> + ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) -> GHC.InteractiveImport -> - m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) + 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) @@ -80,7 +104,7 @@ where name = GHC.moduleNameString . GHC.moduleName decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName -setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.RdrName] -> m () +setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m () setContext ms ds = let ms' = map modToIIMod ms ds' = map GHC.IIDecl ds @@ -157,7 +181,7 @@ if safeToRemove then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets return $ guard (isSucceeded res) >> Just () - liftIO $ removeFile (pmFile pm) + `finally` do liftIO $ removeFile (pmFile pm) else onState (\s -> s{zombiePhantoms = pm:zombiePhantoms s}) -- Returns a tuple with the active and zombie phantom modules respectively @@ -225,7 +249,8 @@ getLoadedModSummaries :: MonadInterpreter m => m [GHC.ModSummary] getLoadedModSummaries = do all_mod_summ <- runGhc GHC.getModuleGraph - filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) all_mod_summ + filterM (runGhc1 GHC.isLoaded . GHC.ms_mod_name) + (GHC.mgModSummaries all_mod_summ) -- | Sets the modules whose context is used during evaluation. All bindings -- of these modules are in scope, not only those exported. @@ -254,13 +279,13 @@ -- | Sets the modules whose exports must be in context. -- --- Warning: 'setImports' and 'setImportsQ' are mutually exclusive. +-- Warning: 'setImports', 'setImportsQ', and 'setImportsF' are mutually exclusive. -- If you have a list of modules to be used qualified and another list -- unqualified, then you need to do something like -- -- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) setImports :: MonadInterpreter m => [ModuleName] -> m () -setImports ms = setImportsQ $ zip ms (repeat Nothing) +setImports ms = setImportsF $ map (\m -> ModuleImport m NotQualified NoImportList) ms -- | Sets the modules whose exports must be in context; some -- of them may be qualified. E.g.: @@ -269,32 +294,52 @@ -- -- Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map. setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m () -setImportsQ ms = - do let qualOrNot (a, mb) = maybe (Right a) (Left . (,) a) mb - (quals, unquals) = Util.partitionEither $ map qualOrNot ms - -- - unqual_mods <- mapM findModule unquals - mapM_ (findModule . fst) quals -- just to be sure they exist +setImportsQ ms = setImportsF $ map (\(m,q) -> ModuleImport m (maybe NotQualified (QualifiedAs . Just) q) NoImportList) ms + +-- | Sets the modules whose exports must be in context; some +-- may be qualified or have imports lists. E.g.: +-- +-- @setImportsF [ModuleImport "Prelude" NotQualified NoImportList, ModuleImport "Data.Text" (QualifiedAs $ Just "Text") (HidingList ["pack"])]@ + +setImportsF :: MonadInterpreter m => [ModuleImport] -> m () +setImportsF ms = 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 not $ null quals - then do + new_pm <- if null phantomImports + then return Nothing + else do new_pm <- addPhantomModule $ \mod_name -> unlines $ ("module " ++ mod_name ++ " where ") : - ["import qualified " ++ m ++ " as " ++ n | - (m,n) <- quals] + map newImportLine phantomImports onState (\s -> s{importQualHackMod = Just new_pm}) return $ Just new_pm - else return Nothing -- pm <- maybe (return []) (findModule . pmName >=> return . return) new_pm (old_top_level, _) <- runGhc getContext let new_top_level = pm ++ old_top_level - runGhc2 setContextModules new_top_level unqual_mods + runGhc2 setContextModules new_top_level regularMods -- - onState (\s ->s{qualImports = quals}) + onState (\s ->s{qualImports = phantomImports}) + where + (regularImports, phantomImports) = partitionEithers $ map (\m -> if isQualified m || hasImportList m + then Right m + else Left m) ms + isQualified m = modQual m /= NotQualified + hasImportList m = modImp m /= NoImportList + newImportLine m = concat ["import ", case modQual m of + NotQualified -> modName m + ImportAs q -> modName m ++ " as " ++ q + QualifiedAs Nothing -> "qualified " ++ modName m + QualifiedAs (Just q) -> "qualified " ++ modName m ++ " as " ++ q + ,case modImp m of + NoImportList -> "" + ImportList l -> " (" ++ intercalate "," l ++ ")" + HidingList l -> " hiding (" ++ intercalate "," l ++ ")" + ] -- | 'cleanPhantomModules' works like 'reset', but skips the -- loading of the support module that installs '_show'. Its purpose @@ -322,6 +367,11 @@ 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 @@ -1,11 +1,14 @@ module Hint.Eval ( interpret, as, infer, unsafeInterpret, - eval, parens + eval, runStmt, + parens ) where import qualified GHC.Exts (unsafeCoerce#) +import Control.Exception + import Data.Typeable hiding (typeOf) import qualified Data.Typeable (typeOf) @@ -54,6 +57,22 @@ in_scope_String <- supportString let show_expr = unwords [in_scope_show, parens expr] unsafeInterpret show_expr in_scope_String + +-- | Evaluate a statement in the 'IO' monad, possibly binding new names. +-- +-- Example: +-- +-- > runStmt "x <- return 42" +-- > runStmt "print x" +runStmt :: (MonadInterpreter m) => String -> m () +runStmt = mayFail . runGhc1 go + where + go statements = do + result <- GHC.execStmt statements GHC.execOptions + return $ case result of + GHC.ExecComplete { GHC.execResult = Right _ } -> Just () + GHC.ExecComplete { GHC.execResult = Left e } -> throw e + _ -> Nothing -- | Conceptually, @parens s = \"(\" ++ s ++ \")\"@, where s is any valid haskell -- expression. In practice, it is harder than this. diff --git a/src/Hint/Extension.hs b/src/Hint/Extension.hs --- a/src/Hint/Extension.hs +++ b/src/Hint/Extension.hs @@ -9,11 +9,7 @@ supportedExtensions :: [String] supportedExtensions = map f GHC.xFlags where -#if (__GLASGOW_HASKELL__ >= 710) f = GHC.flagSpecName -#else - f (e,_,_) = e -#endif -- | List of the extensions known by the interpreter. availableExtensions :: [Extension] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -1,11 +1,17 @@ module Hint.GHC ( - Message, module X + Message, module X, +#if __GLASGOW_HASKELL__ < 804 + GhcPs, mgModSummaries +#endif ) 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, @@ -19,15 +25,9 @@ import Parser as X (parseStmt, parseType) import FastString as X (fsLit) -#if __GLASGOW_HASKELL__ >= 710 import DynFlags as X (xFlags, xopt, LogAction, FlagSpec(..)) -#else -import DynFlags as X (xFlags, xopt, LogAction) -#endif -#if __GLASGOW_HASKELL__ >= 800 import DynFlags as X (WarnReason(NoReason)) -#endif import PprTyThing as X (pprTypeForUser) import SrcLoc as X (mkRealSrcLoc) @@ -37,3 +37,10 @@ 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/Internal.hs b/src/Hint/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Internal.hs @@ -0,0 +1,33 @@ +-- | In this module we intend to export some internal functions. +-- +-- __Important note__: the authors of this library imply no assurance whatsoever +-- of the stability or functionality of the API exposed here, and compatibility +-- may break even by minor version changes. Rely on these at your +-- own risk. +-- +-- The reason for showing them here is to aid discoverability +-- of already written code and prevent having to reinvent the wheel from +-- scratch if said wheel is already invented. +-- +-- In case you find something here especially useful, please submit +-- an issue or a pull request at https://github.com/mvdan/hint so +-- we can discuss making it part of the official public API. +-- +-- Some further context can be found here: +-- https://github.com/mvdan/hint/pull/48#issuecomment-358722638 + + + +module Hint.Internal ( + onCompilationError +) where + +import Hint.Typecheck (onCompilationError) + + + +-- todo: Consider refactoring like the following when +-- https://github.com/haskell/haddock/issues/563 is fixed +-- +-- module Hint.Internal (module ReExport) where +-- import Hint.Typecheck as ReExport (onCompilationError) diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -33,11 +33,8 @@ } deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) -execute :: (MonadIO m, MonadMask m -#if __GLASGOW_HASKELL__ < 800 - , Functor m -#endif - ) => String +execute :: (MonadIO m, MonadMask m) + => String -> InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a) @@ -49,11 +46,8 @@ instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift -runGhcImpl :: (MonadIO m, MonadMask m -#if __GLASGOW_HASKELL__ < 800 - , MonadThrow m, Functor m -#endif - ) => RunGhc (InterpreterT m) a +runGhcImpl :: (MonadIO m, MonadMask m) + => RunGhc (InterpreterT m) a runGhcImpl a = InterpreterT (lift a) `catches` @@ -94,11 +88,7 @@ -- available; calling this function once is mandatory! _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler} -#if __GLASGOW_HASKELL__ >= 710 let extMap = map (\fs -> (GHC.flagSpecName fs, GHC.flagSpecFlag fs)) GHC.xFlags -#else - let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags -#endif 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) @@ -110,34 +100,25 @@ -- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. -- --- 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 :: (MonadIO m, MonadMask m -#if __GLASGOW_HASKELL__ < 800 - , Functor m -#endif - ) => InterpreterT m a +-- NB. In hint-0.7.0 and earlier, the underlying ghc was accidentally +-- overwriting certain signal handlers (SIGINT, SIGHUP, SIGTERM, SIGQUIT on +-- Posix systems, Ctrl-C handler on Windows). +runInterpreter :: (MonadIO m, MonadMask m) + => InterpreterT m a -> m (Either InterpreterError a) runInterpreter = runInterpreterWithArgs [] -- | Executes the interpreter, setting args passed in as though they -- were command-line args. Returns @Left InterpreterError@ in case of -- error. -runInterpreterWithArgs :: (MonadIO m, MonadMask m -#if __GLASGOW_HASKELL__ < 800 - , Functor m -#endif - ) => [String] +runInterpreterWithArgs :: (MonadIO m, MonadMask m) + => [String] -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgs args = runInterpreterWithArgsLibdir args GHC.Paths.libdir -runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m -#if __GLASGOW_HASKELL__ < 800 - , Functor m -#endif - ) => [String] +runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m) + => [String] -> String -> InterpreterT m a -> m (Either InterpreterError a) @@ -149,10 +130,6 @@ newInterpreterSession = newSessionData () cleanSession = do cleanPhantomModules -#if __GLASGOW_HASKELL__ < 800 - runGhc $ do dflags <- GHC.getSessionDynFlags - GHC.defaultCleanupHandler dflags (return ()) -#endif {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () @@ -180,6 +157,9 @@ initialState = St { activePhantoms = [], zombiePhantoms = [], +#if defined(NEED_PHANTOM_DIRECTORY) + phantomDirectory = Nothing, +#endif hintSupportModule = error "No support module loaded!", importQualHackMod = Nothing, qualImports = [], @@ -199,11 +179,7 @@ } mkLogHandler :: IORef [GhcError] -> GhcErrLogger -#if __GLASGOW_HASKELL__ >= 800 mkLogHandler r df _ _ src style msg = -#else -mkLogHandler r df _ src style msg = -#endif let renderErrMsg = GHC.showSDoc df errorEntry = mkGhcError renderErrMsg src style msg in modifyIORef r (errorEntry :) @@ -224,10 +200,6 @@ -- runGhc = runGhcImpl -#if __GLASGOW_HASKELL__ >= 800 instance (Monad m) => Applicative (InterpreterT m) where -#else -instance (Monad m, Applicative m) => Applicative (InterpreterT m) where -#endif pure = return (<*>) = ap diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -29,7 +29,12 @@ case parse_res of GHC.POk{} -> return ParseOk -- - GHC.PFailed span err -> return (ParseError span err) +#if __GLASGOW_HASKELL__ >= 804 + GHC.PFailed _ span err +#else + GHC.PFailed span err +#endif + -> return (ParseError span err) failOnParseError :: MonadInterpreter m => (String -> m ParseResult) @@ -51,9 +56,7 @@ let logger' = logger dflags errStyle = GHC.defaultErrStyle dflags liftIO $ logger' -#if __GLASGOW_HASKELL__ >= 800 GHC.NoReason -#endif GHC.SevError span errStyle diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs --- a/src/Hint/Reflection.hs +++ b/src/Hint/Reflection.hs @@ -47,7 +47,7 @@ ( [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 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] diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs --- a/src/Hint/Typecheck.hs +++ b/src/Hint/Typecheck.hs @@ -1,5 +1,5 @@ module Hint.Typecheck ( - typeOf, typeChecks, kindOf, normalizeType + typeOf, typeChecks, kindOf, normalizeType, onCompilationError, typeChecksWithDetails ) where import Control.Monad.Catch @@ -23,10 +23,20 @@ typeToString ty -- | Tests if the expression type checks. +-- +-- NB. Be careful if there is `-fdefer-type-errors` involved. +-- 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) `catchIE` onCompilationError (\_ -> return False) + +-- | Similar to @typeChecks@, but gives more information, e.g. the type errors. +typeChecksWithDetails :: MonadInterpreter m => String -> m (Either [GhcError] String) +typeChecksWithDetails expr = (Right <$> typeOf expr) + `catchIE` + onCompilationError (return . Left) -- | Returns a string representation of the kind of the type expression. kindOf :: MonadInterpreter m => String -> m String 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 @@ -22,8 +22,9 @@ -- ** Context handling ModuleName, isModuleInterpreted, + ModuleImport(..), ModuleQualification(..), ImportList(..), loadModules, getLoadedModules, setTopLevelModules, - setImports, setImportsQ, + setImports, setImportsQ, setImportsF, reset, -- ** Module querying ModuleElem(..), Id, name, children, @@ -34,9 +35,10 @@ -- pragmas inline in the code since GHC scarfs them up. getModuleAnnotations, getValAnnotations, -- ** Type inference + typeChecksWithDetails, typeOf, typeChecks, kindOf, normalizeType, -- ** Evaluation - interpret, as, infer, eval, + interpret, as, infer, eval, runStmt, -- * Error handling InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous 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 @@ -24,11 +24,8 @@ -- context. -- -- Warning: Some options may interact badly with the Interpreter. -unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m -#if __GLASGOW_HASKELL__ < 800 - , Functor m -#endif - ) => [String] +unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m) + => [String] -> InterpreterT m a -> m (Either InterpreterError a) unsafeRunInterpreterWithArgs = runInterpreterWithArgs @@ -39,11 +36,8 @@ -- a machine in which GHC is not installed. -- -- A typical libdir value could be "/usr/lib/ghc-8.0.1/ghc-8.0.1". -unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m -#if __GLASGOW_HASKELL__ < 800 - , Functor m -#endif - ) => [String] +unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m) + => [String] -> String -> InterpreterT m a -> m (Either InterpreterError a) 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,18 +2,24 @@ import Prelude hiding (catch) -import Control.Exception.Extensible (ArithException(..)) +import Control.Exception.Extensible (ArithException(..), AsyncException(UserInterrupt)) import Control.Monad.Catch as MC import Control.Monad (liftM, when, void, (>=>)) -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar +import Data.IORef + import System.IO import System.FilePath import System.Directory import System.Exit +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#else +import System.Posix.Signals +#endif import Test.HUnit ((@?=), (@?)) import qualified Test.HUnit as HUnit @@ -68,7 +74,7 @@ loadModules [mod_file] setTopLevelModules ["Main"] setImportsQ [("Prelude", Nothing), - ("Data.Maybe", Just "Mb")] + ("Data.Maybe", Just "Mb")] -- typeOf "f $ (1 + 1 :: Int)" @@?= "Int" eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]" @@ -104,6 +110,14 @@ typeChecks "null []" @@? "Unqual null" typeChecks "M.null M.empty" @@? "Qual null" +test_full_import :: TestCase +test_full_import = TestCase "full_import" [] $ do + setImportsF [ ModuleImport "Prelude" (QualifiedAs Nothing) NoImportList + , ModuleImport "Data.List" (QualifiedAs $ Just "List") $ ImportList ["null"] + ] + typeChecks "Prelude.null []" @@? "Qual prelude null" + typeChecks "List.null []" @@? "Qual list null" + test_basic_eval :: TestCase test_basic_eval = TestCase "basic_eval" [] $ eval "()" @@?= "()" @@ -213,12 +227,54 @@ ,"type instance Foo x = ()"] mod_file = "TEST_NormalizeType.hs" +-- earlier versions of hint were accidentally overwriting the signal handlers +-- for ^C and others. +-- +-- note that hint was _not_ overwriting the signal handlers when the hint interpreter +-- was itself executed inside the ghci interpreter. for this reason, this test always +-- succeeds when executed from ghci and ghcid, regardless of whether the problematic +-- behaviour has been fixed or not. +test_signal_handlers :: IOTestCase +test_signal_handlers = IOTestCase "signal_handlers" [] $ \runInterp -> do +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + runInterp $ do + pure () +#else + signalDetectedRef <- newIORef False + interruptDetectedRef <- newIORef False + let detectSignal = writeIORef signalDetectedRef True + detectInterrupt = writeIORef interruptDetectedRef True + acquire = installHandler sigINT (Catch detectSignal) Nothing + release handler = installHandler sigINT handler Nothing + r <- bracket acquire release $ \_ -> do + runInterp $ do + liftIO $ do + r <- try $ do + raiseSignal sigINT + threadDelay 1000000 -- will be interrupted by the above signal + case r of + Left UserInterrupt -> do + -- hint is _still_ accidentally overwriting the signal handler :( + detectInterrupt + Left e -> do + -- some other async exception, rethrow + throwM e + Right () -> + return () + signalDetected <- readIORef signalDetectedRef + signalDetected @?= True + interruptDetected <- readIORef interruptDetectedRef + interruptDetected @?= False + return r +#endif + tests :: [TestCase] tests = [test_reload_modified ,test_lang_exts ,test_work_in_main ,test_comments_in_expr ,test_qual_import + ,test_full_import ,test_basic_eval ,test_eval_layout ,test_show_in_scope @@ -231,14 +287,22 @@ ,test_normalize_type ] +ioTests :: [IOTestCase] +ioTests = [test_signal_handlers + ] + main :: IO () main = do -- run the tests... - c <- runTests False tests + c1 <- runTests False tests + c2 <- runIOTests False ioTests -- then run again, but with sandboxing on... - c' <- runTests True tests + c3 <- runTests True tests + c4 <- runIOTests True ioTests -- - let failures = HUnit.errors c + HUnit.failures c + - HUnit.errors c' + HUnit.failures c' + let failures = HUnit.errors c1 + HUnit.failures c1 + + HUnit.errors c2 + HUnit.failures c2 + + HUnit.errors c3 + HUnit.failures c3 + + HUnit.errors c4 + HUnit.failures c4 exit_code | failures > 0 = ExitFailure failures | otherwise = ExitSuccess @@ -266,16 +330,16 @@ succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool succeeds = liftM not . fails -data TestCase = TestCase String [FilePath] (Interpreter ()) +data IOTestCase = IOTestCase String [FilePath] ((Interpreter () -> IO (Either InterpreterError ())) -> IO (Either InterpreterError ())) -runTests :: Bool -> [TestCase] -> IO HUnit.Counts -runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build - where build (TestCase title tmps test) = HUnit.TestLabel title $ - HUnit.TestCase test_case +runIOTests :: Bool -> [IOTestCase] -> IO HUnit.Counts +runIOTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build + where build (IOTestCase title tmps test) = HUnit.TestLabel title $ + HUnit.TestCase test_case where test_case = go `finally` clean_up clean_up = mapM_ removeIfExists tmps - go = do r <- runInterpreter - (when sandboxed setSandbox >> test) + go = do r <- test (\body -> runInterpreter + (when sandboxed setSandbox >> body)) either (printInterpreterError >=> (fail . show)) return r removeIfExists f = do existsF <- doesFileExist f @@ -285,3 +349,11 @@ do existsD <- doesDirectoryExist f when existsD $ removeDirectory f + +data TestCase = TestCase String [FilePath] (Interpreter ()) + +runTests :: Bool -> [TestCase] -> IO HUnit.Counts +runTests sandboxed = runIOTests sandboxed . map toIOTestCase + where + toIOTestCase :: TestCase -> IOTestCase + toIOTestCase (TestCase title tmps test) = IOTestCase title tmps ($ test)