hint 0.7.0 → 0.8.0

raw patch · 21 files changed

+374/−149 lines, 21 filesdep +ghc-bootdep +temporarydep ~exceptionsdep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-boot, temporary

Dependency ranges changed: exceptions, ghc

API changes (from Hackage documentation)

Files

• AUTHORS +1/−0
• CHANGELOG.md +14/−1
• README.md +4/−0
• examples/example.hs +7/−0
• hint.cabal +17/−4
• src/Control/Monad/Ghc.hs +28/−7
• src/Hint/Annotations.hs +2/−2
• src/Hint/Base.hs +23/−23
• src/Hint/Configuration.hs +8/−0
• src/Hint/Context.hs +75/−25
• src/Hint/Eval.hs +20/−1
• src/Hint/Extension.hs +0/−4
• src/Hint/GHC.hs +14/−7
• src/Hint/Internal.hs +33/−0
• src/Hint/InterpreterT.hs +16/−44
• src/Hint/Parsers.hs +6/−3
• src/Hint/Reflection.hs +1/−1
• src/Hint/Typecheck.hs +11/−1
• src/Language/Haskell/Interpreter.hs +4/−2
• src/Language/Haskell/Interpreter/Unsafe.hs +4/−10
• unit-tests/run-unit-tests.hs +86/−14

@@ -12,6 +12,7 @@ Evan Laforge Fernando Benavides Gwern Branwen+Heinrich Apfelmus Jean Philippe Bernardy Jens Petersen Mark Wright

@@ -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<nnn>.hs` instead of `<nnn>`+  - 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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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.

@@ -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]

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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)

@@ -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)