diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,23 @@ +# Please keep the list sorted. + +Austin Seipp +Bertram Felgenhauer +Bryan O'Sullivan +Carl Howells +Conrad Parker +Corentin Dupont +Daniel Gorin +Daniel Martí +Daniel Wagner +Evan Laforge +Fernando Benavides +Gwern Branwen +Heinrich Apfelmus +Jean Philippe Bernardy +Jens Petersen +Mark Wright +Nathaniel W. Filardo +Pasqualino Titto Assini +Rob Zinkov +Samuel Gélineau +Sid Kapur diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,201 @@ +### 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 +* Support use in a dynamically-linked executable +* Add `normalizeType`, like ghci's :kind! +* Drop support for GHC 7.6 + +### 0.6.0 + +* Support for GHC 8.0 +* Add `displayException` to InterpreterError + +### 0.5.2 + +* Add `runInterpreter` variant that takes a GHC libdir at runtime +* Add missing negated extensions to the `Extension` type +* Do not throw GHC warnings as errors + +### 0.5.1 + +* Expose `unsafeInterpret` in `Language.Haskell.Interpreter.Unsafe` + +### 0.5.0 + +* Drop support for GHC 7.4 +* Remove deprecated functions and modules: + - `glasgowExtensions` + - `setUseLanguageExtensions` + - `setInstalledModsAreInScopeQualified` + - `Language.Haskell.Interpreter.GHC` + - `Language.Haskell.Interpreter.GHC.Unsafe` +* Drop dependencies on `ghc-mtl` and `extensible-exceptions` + +### 0.4.3 + +* New maintainer and source code repo + +### 0.4.2.3 + +* It builds against 7.4.2 (not 7.4.1), so update the constraints. + +### 0.4.2.2 + +* Builds with GHC 7.10 +* Builds again with GHC 7.4 +* Drops dependency on `utf8-string` + +### 0.4.2.1 + +* Better error reporting (thanks to Corentin Dupont) + +### 0.4.2.0 + +* Based on exceptions-0.6 + +### 0.4.1.0 + +* Based on exceptions-0.4 + +### 0.4.0.0 + +* Compiles with GHC 7.8 +* Fixed an issue where `P` was available as a qualified version of + Prelude (thanks to Samuel Gélineau) +* Uses `exceptions` package instead of `MonadCatchIO-mtl` (API breakage + expected) +* No longer depends on `haskell-src` +* Changelog should now appear in Hackage +* Integrated unit tests with cabal + +### 0.3.3.7 + +* Fixed a race condition that would happen, for instance, when two + process where run one next to the other, making them, on some + platforms, to get the same random number seed (thanks to Mario + Pastorelli and Samuel Gélineau) +* Small fix in documentation (thanks to Daniil Frumin) + +### 0.3.3.6 + +* Works again on GHC 7.2.x (thanks to Björn Peemöller) + +### 0.3.3.5 + +* Works on GHC 7.4.6 +* Cleans up files for phantom modules that were left behind (thanks to + Beltram Felgenhauer) + +### 0.3.3.4 + +* Works on GHC 7.4.1 + +### 0.3.3.3 + +* Works on GHC 7.2.1 + +### 0.3.3.2 + +* Supports GHC 7 + +### 0.3.3.1 + +* Instance declaration for Applicative (InterpreterT m) works with mtl-2 + (requires Applicative m, this shouldn't break anything...) + +### 0.3.3.0 + +* Add unsafeRunInterpreterWithArgs +* Check that only one instance of the interpreter is run at any time + +### 0.3.2.3 + +* Can be built against MonadCatchIO-mtl-0.3.x.x + +### 0.3.2.2 + +* Fixed a bug that would make expressions using heavy use of the layout + rule to fail to be interpreted (see parens) + +### 0.3.2.1 + +* hint.cabal includes version bounds for package ghc-mtl. This is to + avoid the accidental selection of the completely unrelated ghc-mtl + internal to GHC and, apparently, installed in the hackage server + +### 0.3.2.0 + +* Exports functions parens and isInterpretedModule +* Experimental support for module annotations +* Uses extensible-exceptions in order to provide a uniform interface + across different ghc versions +* Provides an Applicative instance for IntepreterT +* Adds an option to configurate the searchPath + +### 0.3.1.0 + +* No longer uses Language.Haskell.Extension due to configuration + problems with Cabal. Instead, it uses its own + Language.Haskell.Interpreter.Extension module. + +### 0.3.0.0 + +* Updated API: + + InterpreterT monad transformer (Interpreter = InterpreterT IO) + + No more Sessions, use runInterpreter only once + + New options handling functions + - but observe that there is no setOptimizations equivalent; since + GHC does no optimization on interpreted code, this was actually + doing nothing +* Works with GHC 6.10 and 6.8 (untested with 6.6) + +### 0.2.5 + +* setImportsQ added (modules can be imported both qualified and + unqualified) + +### 0.2.4.1 + +* BUGFIX: No longer fails on expressions ending in a -- comment + +### 0.2.4 + +* setInstalledModsAreInScopeQualified added +* Now depends on ghc-paths (no longer needs a custom cabal script) + +### 0.2.2 + +* setOptimizations added +* Module Language.Haskell.Interpreter.GHC.Unsafe added (contains + unsafeSetGhcOption) +* Unit tests now based on HUnit + +### 0.2.1 + +* BUGFIX: Module reloading was broken under 6.8 +* GHC.GhcExceptions are catched and turned into InterpreterErrors + +### 0.2.0.1 + +* Adds the requirement cabal-version < 1.3 + +### 0.2 + +* Works also with GHC 6.8 and 6.6 +* Added the getModuleExports function +* withSession function throws a dynamic exception instead of returning + Either Error a +* Requires Cabal 1.2.x diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2007 The Hint Authors. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. + * Neither the name of the copyright holder nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# hint + +[![Build Status](https://travis-ci.org/mvdan/hint.svg?branch=master)](https://travis-ci.org/mvdan/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). + +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 +comprehensive example (it must be run from the `examples` directory). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/SomeModule.hs b/examples/SomeModule.hs new file mode 100644 --- /dev/null +++ b/examples/SomeModule.hs @@ -0,0 +1,7 @@ +module SomeModule(g, h) where + +f = head + +g = f [f] + +h = f diff --git a/examples/example.hs b/examples/example.hs new file mode 100644 --- /dev/null +++ b/examples/example.hs @@ -0,0 +1,77 @@ +import Data.List + +import Control.Monad +import Language.Haskell.Interpreter + +main :: IO () +main = do r <- runInterpreter testHint + case r of + Left err -> putStrLn $ errorString err + Right () -> return () + +errorString :: InterpreterError -> String +errorString (WontCompile es) = intercalate "\n" (header : map unbox es) + where + header = "ERROR: Won't compile:" + unbox (GhcError e) = e +errorString e = show e + +say :: String -> Interpreter () +say = liftIO . putStrLn + +emptyLine :: Interpreter () +emptyLine = say "" + +-- observe that Interpreter () is an alias for InterpreterT IO () +testHint :: Interpreter () +testHint = + do + say "Load SomeModule.hs" + loadModules ["SomeModule.hs"] + emptyLine + say "Put the Prelude, Data.Map and *SomeModule in scope" + say "Data.Map is qualified as M!" + setTopLevelModules ["SomeModule"] + setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")] + emptyLine + say "Now we can query the type of an expression" + let expr1 = "M.singleton (f, g, h, 42)" + say $ "e.g. typeOf " ++ expr1 + say =<< typeOf expr1 + emptyLine + say $ "Observe that f, g and h are defined in SomeModule.hs, " ++ + "but f is not exported. Let's check it..." + exports <- getModuleExports "SomeModule" + say $ show exports + emptyLine + say "We can also evaluate an expression; the result will be a string" + let expr2 = "length $ concat [[f,g],[h]]" + say $ "e.g. eval " ++ show expr2 + a <- eval expr2 + say $ show a + emptyLine + say "Or we can interpret it as a proper, say, int value!" + a_int <- interpret expr2 (as :: Int) + say $ show a_int + emptyLine + say "This works for any monomorphic type, even for function types" + let expr3 = "\\(Just x) -> succ x" + say $ "e.g. we interpret " ++ expr3 ++ + " with type Maybe Int -> Int and apply it on Just 7" + fun <- interpret expr3 (as :: Maybe Int -> Int) + say $ show $ fun (Just 7) + emptyLine + say "And sometimes we can even use the type system to infer the expected type (eg Maybe Bool -> Bool)!" + bool_val <- interpret expr3 infer `ap` return (Just False) + 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 + 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/hinter.cabal b/hinter.cabal new file mode 100644 --- /dev/null +++ b/hinter.cabal @@ -0,0 +1,102 @@ +name: hinter +version: 0.1.0.0 +description: + This library defines an Interpreter monad. It allows to load Haskell + modules, browse them, type-check and evaluate strings with Haskell + expressions and even coerce them into values. The library is thread-safe + and type-safe (even the coercion of expressions to values). + + It is, essentially, a huge subset of the GHC API wrapped in a simpler + API. + +synopsis: Runtime Haskell interpreter (GHC API wrapper) +category: Language, Compilers/Interpreters +license: BSD3 +license-file: LICENSE +author: The Hint Authors +maintainer: strake888@gmail.com +homepage: https://github.com/strake/hint.hs + +cabal-version: >= 1.9.2 +build-type: Simple + +extra-source-files: README.md + AUTHORS + CHANGELOG.md + examples/example.hs + examples/SomeModule.hs + +source-repository head + type: git + location: https://github.com/strake/hint.hs + +test-suite unit-tests + type: exitcode-stdio-1.0 + hs-source-dirs: unit-tests + main-is: run-unit-tests.hs + + build-depends: base == 4.*, + hinter, + HUnit, + directory, + filepath, + extensible-exceptions, + exceptions >= 0.10.0 + + if !os(windows) { + build-depends: unix >= 2.2.0.0 + } + + extensions: CPP + +library + build-depends: base == 4.*, + ghc >= 8.0 && < 8.6, + ghc-paths, + ghc-boot, + mtl, + filepath, + 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 + } + + exposed-modules: Language.Haskell.Interpreter + Language.Haskell.Interpreter.Extension + Language.Haskell.Interpreter.Unsafe + Hint.Internal + other-modules: Hint.GHC + Hint.Base + Hint.InterpreterT + Hint.CompatPlatform + Hint.Configuration + Hint.Extension + Hint.Context + Hint.Conversions + Hint.Eval + Hint.Parsers + Hint.Reflection + Hint.Typecheck + Hint.Util + Hint.Annotations + Control.Monad.Ghc + + hs-source-dirs: src + + ghc-options: -Wall + extensions: CPP + GeneralizedNewtypeDeriving + DeriveDataTypeable + MagicHash + FunctionalDependencies + Rank2Types + ScopedTypeVariables + ExistentialQuantification diff --git a/src/Control/Monad/Ghc.hs b/src/Control/Monad/Ghc.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Ghc.hs @@ -0,0 +1,95 @@ +module Control.Monad.Ghc ( + GhcT, runGhcT +) where + +import Control.Applicative +import Prelude + +import Control.Monad +import Control.Monad.Trans +import qualified Control.Monad.Trans as MTL + +import Control.Monad.Catch + +import Data.IORef + +import qualified GHC +import qualified MonadUtils as GHC +import qualified Exception as GHC +import qualified GhcMonad as GHC + +import qualified DynFlags as GHC + +newtype GhcT m a = GhcT { unGhcT :: GHC.GhcT (MTLAdapter m) a } + deriving (Functor, Monad, GHC.HasDynFlags) + +instance (Functor m, Monad m) => Applicative (GhcT m) where + pure = return + (<*>) = ap + +-- 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 +runGhcT f = unMTLA . rawRunGhcT f . unGhcT + +instance MTL.MonadTrans GhcT where + lift = GhcT . GHC.liftGhcT . MTLAdapter + +instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where + liftIO = GhcT . GHC.liftIO + +instance MonadCatch m => MonadThrow (GhcT m) where + throwM = lift . throwM + +instance (MonadIO m, MonadCatch m, MonadMask m) => MonadCatch (GhcT m) where + m `catch` f = GhcT (unGhcT m `GHC.gcatch` (unGhcT . f)) + +instance (MonadIO m, MonadMask m) => MonadMask (GhcT m) where + mask f = wrap $ \s -> + mask $ \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) + + 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 + gmask f = mask (\x -> f x) + +instance (Functor m, MonadIO m, MonadCatch m, MonadMask m) => GHC.GhcMonad (GhcT m) where + getSession = GhcT GHC.getSession + setSession = GhcT . GHC.setSession + +-- | We use the 'MTLAdapter' to convert between similar classes +-- 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, MonadCatch m, MonadMask m) => GHC.ExceptionMonad (MTLAdapter m) where + m `gcatch` f = MTLAdapter $ unMTLA m `catch` (unMTLA . f) + gmask io = MTLAdapter $ mask (\f -> unMTLA $ io (MTLAdapter . f . unMTLA)) diff --git a/src/Hint/Annotations.hs b/src/Hint/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Annotations.hs @@ -0,0 +1,31 @@ +module Hint.Annotations ( + getModuleAnnotations, + getValAnnotations +) where + +import Control.Monad +import Data.Data +import Annotations +import GHC.Serialized + +import Hint.Base +import HscTypes (hsc_mod_graph, ms_mod) +import qualified Hint.GHC as GHC + +-- Get the annotations associated with a particular module. +getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] +getModuleAnnotations _ x = do + 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 + +-- 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 + +anns :: (MonadInterpreter m, Data a) => AnnTarget GHC.Name -> m [a] +anns = runGhc1 (GHC.findGlobalAnns deserializeWithData) diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Base.hs @@ -0,0 +1,206 @@ +module Hint.Base ( + MonadInterpreter(..), RunGhc, + + GhcError(..), InterpreterError(..), mayFail, catchIE, + + InterpreterSession, SessionData(..), GhcErrLogger, + InterpreterState(..), fromState, onState, + InterpreterConfiguration(..), + ImportList(..), ModuleQualification(..), ModuleImport(..), + + runGhc1, runGhc2, + + ModuleName, PhantomModule(..), + findModule, moduleIsLoaded, + withDynFlags, + + ghcVersion, + + debug, showGHC +) where + +import Control.Monad.Trans +import Control.Monad.Catch as MC + +import Data.IORef +import Data.Dynamic +import qualified Data.List + +import qualified Hint.GHC as GHC + +import Hint.Extension + +-- | Version of the underlying ghc api. Values are: +-- +-- * @802@ for GHC 8.2.x +-- +-- * @804@ for GHC 8.4.x +-- +-- * etc... +ghcVersion :: Int +ghcVersion = __GLASGOW_HASKELL__ + +class (MonadIO m, MonadMask m) => MonadInterpreter m where + fromSession :: FromSession m a + modifySessionRef :: ModifySessionRef m a + runGhc :: RunGhc m a + +-- this is for hiding the actual types in haddock +type FromSession m a = (InterpreterSession -> a) -> m a +type ModifySessionRef m a = (InterpreterSession -> IORef a) -> (a -> a) -> m a + +data InterpreterError = UnknownError String + | WontCompile [GhcError] + | NotAllowed String + -- | GhcExceptions from the underlying GHC API are caught + -- and rethrown as this. + | GhcException String + deriving (Show, Typeable) + +data InterpreterState = St { + activePhantoms :: [PhantomModule], + zombiePhantoms :: [PhantomModule], +#if defined(NEED_PHANTOM_DIRECTORY) + phantomDirectory :: Maybe FilePath, +#endif + hintSupportModule :: PhantomModule, + importQualHackMod :: Maybe PhantomModule, + 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], + allModsInScope :: Bool + } + +type InterpreterSession = SessionData () + +instance Exception InterpreterError + 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 + +type RunGhc m a = + (forall n.(MonadIO n, MonadMask n) => GHC.GhcT n a) + -> m a + +type RunGhc1 m a b = + (forall n.(MonadIO n, MonadMask n) => a -> GHC.GhcT n b) + -> (a -> m b) + +type RunGhc2 m a b c = + (forall n.(MonadIO n, MonadMask n) => a -> b -> GHC.GhcT n c) + -> (a -> b -> m c) + +data SessionData a = SessionData { + internalState :: IORef InterpreterState, + versionSpecific :: a, + ghcErrListRef :: IORef [GhcError], + ghcErrLogger :: GhcErrLogger + } + +-- When intercepting errors reported by GHC, we only get a ErrUtils.Message +-- and a SrcLoc.SrcSpan. The latter holds the file name and the location +-- of the error. However, SrcSpan is abstract and it doesn't provide +-- functions to retrieve the line and column of the error... we can only +-- generate a string with this information. Maybe I can parse this string +-- later.... (sigh) +newtype GhcError = GhcError{errMsg :: String} deriving Show + +mapGhcExceptions :: MonadInterpreter m + => (String -> InterpreterError) + -> m a + -> m a +mapGhcExceptions buildEx action = + action + `MC.catch` (\err -> case err of + GhcException s -> throwM (buildEx s) + _ -> throwM err) + +catchIE :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a +catchIE = MC.catch + +type GhcErrLogger = GHC.LogAction + +-- | Module names are _not_ filepaths. +type ModuleName = String + +runGhc1 :: MonadInterpreter m => RunGhc1 m a b +runGhc1 f a = runGhc (f a) + +runGhc2 :: MonadInterpreter m => RunGhc2 m a b c +runGhc2 f a = runGhc1 (f a) + +-- ================ Handling the interpreter state ================= + +fromState :: MonadInterpreter m => (InterpreterState -> a) -> m a +fromState f = do ref_st <- fromSession internalState + liftIO $ f `fmap` readIORef ref_st + +onState :: MonadInterpreter m => (InterpreterState -> InterpreterState) -> m () +onState f = modifySessionRef internalState f >> return () + +-- =============== Error handling ============================== + +mayFail :: MonadInterpreter m => m (Maybe a) -> m a +mayFail action = + do + maybe_res <- action + -- + es <- modifySessionRef ghcErrListRef (const []) + -- + case (maybe_res, null es) of + (Nothing, True) -> throwM $ UnknownError "Got no error message" + (Nothing, False) -> throwM $ WontCompile (reverse es) + (Just a, _) -> return a + +-- ================= Debugging stuff =============== + +debug :: MonadInterpreter m => String -> m () +debug = liftIO . putStrLn . ("!! " ++) + +showGHC :: (MonadInterpreter m, GHC.Outputable a) => a -> m String +showGHC a + = do unqual <- runGhc GHC.getPrintUnqual + withDynFlags $ \df -> + return $ GHC.showSDocForUser df unqual (GHC.ppr a) + +-- ================ Misc =================================== + +-- this type ought to go in Hint.Context, but ghc dislikes cyclic imports... +data PhantomModule = PhantomModule{pmName :: ModuleName, pmFile :: FilePath} + deriving (Eq, Show) + +findModule :: MonadInterpreter m => ModuleName -> m GHC.Module +findModule mn = mapGhcExceptions NotAllowed $ + runGhc2 GHC.findModule mod_name Nothing + where mod_name = GHC.mkModuleName mn + +moduleIsLoaded :: MonadInterpreter m => ModuleName -> m Bool +moduleIsLoaded mn = (findModule mn >> return True) + `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 diff --git a/src/Hint/CompatPlatform.hs b/src/Hint/CompatPlatform.hs new file mode 100644 --- /dev/null +++ b/src/Hint/CompatPlatform.hs @@ -0,0 +1,31 @@ +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +{-# LANGUAGE ForeignFunctionInterface #-} +#endif +module Hint.CompatPlatform ( + getPID +) where + +import Control.Applicative +import Prelude + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +import Data.Word +#else +import System.Posix.Process +#endif + +getPID :: IO Int + +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +-- This function is not yet in the win32 package, so we have to +-- roll down our own definition. +-- +-- Credit goes where it is deserved: +-- http://www.haskell.org/pipermail/haskell-cafe/2009-February/055097.html +foreign import stdcall unsafe "winbase.h GetCurrentProcessId" + c_GetCurrentProcessId :: IO Word32 + +getPID = fromIntegral <$> c_GetCurrentProcessId +#else +getPID = fromIntegral <$> getProcessID +#endif diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Configuration.hs @@ -0,0 +1,152 @@ +module Hint.Configuration ( + setGhcOption, setGhcOptions, + + defaultConf, + + get, set, Option, OptionVal(..), + + languageExtensions, availableExtensions, Extension(..), + installedModulesInScope, + + searchPath, + + configureDynFlags, parseDynamicFlags, + +) where + +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 +import Hint.Base +import Hint.Util (quote) + +import Hint.Extension + +setGhcOptions :: MonadInterpreter m => [String] -> m () +setGhcOptions opts = + do old_flags <- runGhc GHC.getSessionDynFlags + (new_flags,not_parsed) <- runGhc2 parseDynamicFlags old_flags opts + unless (null not_parsed) $ + throwM $ UnknownError + $ concat ["flags: ", unwords $ map quote not_parsed, + "not recognized"] + _ <- runGhc1 GHC.setSessionDynFlags new_flags + return () + +setGhcOption :: MonadInterpreter m => String -> m () +setGhcOption opt = setGhcOptions [opt] + +defaultConf :: InterpreterConfiguration +defaultConf = Conf { + languageExts = [], + allModsInScope = False, + searchFilePath = ["."] + } + +-- | Available options are: +-- +-- * 'languageExtensions' +-- +-- * 'installedModulesInScope' +-- +-- * 'searchPath' +data Option m a = Option{ + _set :: MonadInterpreter m => a -> m (), + _get :: MonadInterpreter m => m a + } + +data OptionVal m = forall a . (Option m a) := a + +-- | Use this function to set or modify the value of any option. It is +-- invoked like this: +-- +-- @set [opt1 := val1, opt2 := val2,... optk := valk]@ +set :: MonadInterpreter m => [OptionVal m] -> m () +set = mapM_ $ \(opt := val) -> _set opt val + +-- | Retrieves the value of an option. +get :: MonadInterpreter m => Option m a -> m a +get = _get + +-- | Language extensions in use by the interpreter. +-- +-- Default is: @[]@ (i.e. none, pure Haskell 98) +languageExtensions :: MonadInterpreter m => Option m [Extension] +languageExtensions = Option setter getter + where setter es = do resetExtensions + setGhcOptions $ map (extFlag True) es + onConf $ \c -> c{languageExts = es} + -- + getter = fromConf languageExts + -- + resetExtensions = do es <- fromState defaultExts + setGhcOptions $ map (uncurry $ flip extFlag) es + +extFlag :: Bool -> Extension -> String +extFlag = mkFlag + where mkFlag b (UnknownExtension o) = strToFlag b o + mkFlag b o = strToFlag b (show o) + -- + strToFlag b o@('N':'o':(c:_)) + | isUpper c = "-X" ++ drop (if b then 0 else 2) o + strToFlag b o = "-X" ++ concat ["No"|not b] ++ o + +-- | When set to @True@, every module in every available package is implicitly +-- imported qualified. This is very convenient for interactive +-- evaluation, but can be a problem in sandboxed environments +-- (e.g. 'System.Unsafe.unsafePerformIO' is in scope). +-- +-- Default value is @True@. +-- +-- Observe that due to limitations in the GHC-API, when set to @False@, the +-- private symbols in interpreted modules will not be in scope. +installedModulesInScope :: MonadInterpreter m => Option m Bool +installedModulesInScope = Option setter getter + where getter = fromConf allModsInScope + setter b = do onConf $ \c -> c{allModsInScope = b} + setGhcOption $ "-f" ++ + concat ["no-" | not b] ++ + "implicit-import-qualified" + +-- | The search path for source files. Observe that every time it is set, +-- it overrides the previous search path. The default is @[\".\"]@. +-- +-- Keep in mind that by a limitation in ghc, @\".\"@ is always in scope. +searchPath :: MonadInterpreter m => Option m [FilePath] +searchPath = Option setter getter + where getter = fromConf searchFilePath + 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) + +onConf :: MonadInterpreter m + => (InterpreterConfiguration -> InterpreterConfiguration) + -> m () +onConf f = onState $ \st -> st{configuration = f (configuration st)} + +configureDynFlags :: GHC.DynFlags -> GHC.DynFlags +configureDynFlags dflags = + (if GHC.dynamicGhc then GHC.addWay' GHC.WayDyn else id) + dflags{GHC.ghcMode = GHC.CompManager, + GHC.hscTarget = GHC.HscInterpreted, + GHC.ghcLink = GHC.LinkInMemory, + GHC.verbosity = 0} + +parseDynamicFlags :: GHC.GhcMonad m + => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String]) +parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc + where firstTwo (a,b,_) = (a, map GHC.unLoc b) diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Context.hs @@ -0,0 +1,436 @@ +module Hint.Context ( + isModuleInterpreted, + loadModules, getLoadedModules, setTopLevelModules, + setImports, setImportsQ, setImportsF, + reset, + + PhantomModule(..), + cleanPhantomModules, + + supportString, supportShow +) where + +import Prelude hiding (mod) + +import Data.Char +import Data.Either (partitionEithers) +import Data.List + +import Control.Arrow ((***)) + +import Control.Monad (liftM, filterM, unless, guard, foldM, (>=>)) +import Control.Monad.Trans (liftIO) +import Control.Monad.Catch + +import Hint.Base +import Hint.Conversions +import qualified Hint.CompatPlatform as Compat + +import qualified Hint.GHC as GHC + +import System.Random +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 +-- @Hint.Util.safeBndFor@: we want to avoid picking a module name that is +-- already in-scope. Additionally, since this may be used with sandboxing in +-- mind we want to avoid easy-to-guess names. Thus, we do a trick similar +-- to the one in safeBndFor, but including a random number instead of an +-- additional digit. Finally, to avoid clashes between two processes +-- that are concurrently running with the same random seed (e.g., initialized +-- with the system time with not enough resolution), we also include the process id +newPhantomModule :: MonadInterpreter m => m PhantomModule +newPhantomModule = + do n <- liftIO randomIO + p <- liftIO Compat.getPID + (ls,is) <- allModulesInContext + let nums = concat [show (abs n::Int), show p, filter isDigit $ concat (ls ++ is)] + let mod_name = 'M':nums + -- + tmp_dir <- getPhantomDirectory + -- + 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.GhcPs]) +getContext = GHC.getContext >>= foldM f ([], []) + where + f :: (GHC.GhcMonad m) => + ([GHC.Module], [GHC.ImportDecl GHC.GhcPs]) -> + GHC.InteractiveImport -> + 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) + +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 + decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName + +setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.GhcPs] -> m () +setContext ms ds = + let ms' = map modToIIMod ms + ds' = map GHC.IIDecl ds + is = ms' ++ ds' + in GHC.setContext is + +-- Explicitly-typed variants of getContext/setContext, for use where we modify +-- or override the context. +setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () +setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName) + +fileTarget :: FilePath -> GHC.Target +fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing + where next_phase = GHC.Cpp GHC.HsSrcFile + +addPhantomModule :: MonadInterpreter m + => (ModuleName -> ModuleText) + -> m PhantomModule +addPhantomModule mod_text = + do pm <- newPhantomModule + let t = fileTarget (pmFile pm) + m = GHC.mkModuleName (pmName pm) + -- + liftIO $ writeFile (pmFile pm) (mod_text $ pmName pm) + -- + onState (\s -> s{activePhantoms = pm:activePhantoms s}) + mayFail (do -- GHC.load will remove all the modules from scope, so first + -- we save the context... + (old_top, old_imps) <- runGhc getContext + -- + runGhc1 GHC.addTarget t + res <- runGhc1 GHC.load (GHC.LoadUpTo m) + -- + if isSucceeded res + then do runGhc2 setContext old_top old_imps + return $ Just () + else return Nothing) + `catchIE` (\err -> case err of + WontCompile _ -> do removePhantomModule pm + throwM err + _ -> throwM err) + -- + return pm + +removePhantomModule :: 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 + -- user didn't require that (they may be in a non-compiling state!). + -- However, this means that we can't actually delete the file, because + -- it is an active target. Therefore, we simply take it out of scope + -- and mark it as "delete me when possible" (i.e., next time the + -- @loadModules@ function is called). + -- + isLoaded <- moduleIsLoaded $ pmName pm + safeToRemove <- + if isLoaded + then do -- take it out of scope + mod <- findModule (pmName pm) + (mods, imps) <- runGhc getContext + let mods' = filter (mod /=) mods + runGhc2 setContext mods' imps + -- + let isNotPhantom = isPhantomModule . moduleToString >=> + return . not + null `liftM` filterM isNotPhantom mods' + else return True + -- + let file_name = pmFile pm + runGhc1 GHC.removeTarget (GHC.targetId $ fileTarget file_name) + -- + onState (\s -> s{activePhantoms = filter (pm /=) $ activePhantoms s}) + -- + if safeToRemove + then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets + return $ guard (isSucceeded res) >> Just () + `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 +getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule]) +getPhantomModules = do active <- fromState activePhantoms + zombie <- fromState zombiePhantoms + return (active, zombie) + +isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool +isPhantomModule mn = do (as,zs) <- getPhantomModules + return $ mn `elem` map pmName (as ++ zs) + +-- | Tries to load all the requested modules from their source file. +-- Modules my be indicated by their ModuleName (e.g. \"My.Module\") or +-- by the full path to its source file. +-- +-- The interpreter is 'reset' both before loading the modules and in the event +-- of an error. +-- +-- /IMPORTANT/: Like in a ghci session, this will also load (and interpret) +-- any dependency that is not available via an installed package. Make +-- sure that you are not loading any module that is also being used to +-- compile your application. In particular, you need to avoid modules +-- that define types that will later occur in an expression that you will +-- want to interpret. +-- +-- The problem in doing this is that those types will have two incompatible +-- representations at runtime: 1) the one in the compiled code and 2) the +-- one in the interpreted code. When interpreting such an expression (bringing +-- it to program-code) you will likely get a segmentation fault, since the +-- latter representation will be used where the program assumes the former. +-- +-- The rule of thumb is: never make the interpreter run on the directory +-- with the source code of your program! If you want your interpreted code to +-- use some type that is defined in your program, then put the defining module +-- on a library and make your program depend on that package. +loadModules :: MonadInterpreter m => [String] -> m () +loadModules fs = do -- first, unload everything, and do some clean-up + reset + doLoad fs `catchIE` (\e -> reset >> throwM e) + +doLoad :: MonadInterpreter m => [String] -> m () +doLoad fs = mayFail $ do + targets <- mapM (\f->runGhc2 GHC.guessTarget f Nothing) fs + -- + runGhc1 GHC.setTargets targets + res <- runGhc1 GHC.load GHC.LoadAllTargets + -- loading the targets removes the support module + reinstallSupportModule + return $ guard (isSucceeded res) >> Just () + +-- | Returns True if the module was interpreted. +isModuleInterpreted :: MonadInterpreter m => ModuleName -> m Bool +isModuleInterpreted m = findModule m >>= runGhc1 GHC.moduleIsInterpreted + +-- | 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 + 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) + +-- | Sets the modules whose context is used during evaluation. All bindings +-- of these modules are in scope, not only those exported. +-- +-- Modules must be interpreted to use this function. +setTopLevelModules :: MonadInterpreter m => [ModuleName] -> m () +setTopLevelModules ms = + do loaded_mods_ghc <- getLoadedModSummaries + -- + let not_loaded = ms \\ map modNameFromSummary loaded_mods_ghc + unless (null not_loaded) $ + throwM $ NotAllowed ("These modules have not been loaded:\n" ++ + unlines not_loaded) + -- + active_pms <- fromState activePhantoms + ms_mods <- mapM findModule (nub $ ms ++ map pmName active_pms) + -- + let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted + not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods + unless (null not_interpreted) $ + throwM $ NotAllowed ("These modules are not interpreted:\n" ++ + unlines (map moduleToString not_interpreted)) + -- + (_, old_imports) <- runGhc getContext + runGhc2 setContext ms_mods old_imports + +-- | Sets the modules whose exports must be in context. +-- +-- 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 = 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.: +-- +-- @setImportsQ [("Prelude", Nothing), ("Data.Map", Just "M")]@. +-- +-- Here, "map" will refer to Prelude.map and "M.map" to Data.Map.map. +setImportsQ :: MonadInterpreter m => [(ModuleName, Maybe String)] -> m () +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 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 + -- + 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 regularMods + -- + 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 +-- is to clean up all temporary files generated for phantom modules. +cleanPhantomModules :: MonadInterpreter m => m () +cleanPhantomModules = + do -- Remove all modules from context + runGhc2 setContext [] [] + -- + -- Unload all previously loaded modules + runGhc1 GHC.setTargets [] + _ <- runGhc1 GHC.load GHC.LoadAllTargets + -- + -- At this point, GHCi would call rts_revertCAFs and + -- reset the buffering of stdin, stdout and stderr. + -- Should we do any of these? + -- + -- liftIO $ rts_revertCAFs + -- + -- We now remove every phantom module and forget about qual imports + old_active <- fromState activePhantoms + old_zombie <- fromState zombiePhantoms + onState (\s -> s{activePhantoms = [], + zombiePhantoms = [], + 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 +-- GHCi, but observe that not even the Prelude will be in +-- context after a reset. +reset :: MonadInterpreter m => m () +reset = do -- clean up context + cleanPhantomModules + -- + -- Now, install a support module + installSupportModule + +-- Load a phantom module with all the symbols from the prelude we need +installSupportModule :: MonadInterpreter m => m () +installSupportModule = do mod <- addPhantomModule support_module + onState (\st -> st{hintSupportModule = mod}) + mod' <- findModule (pmName mod) + runGhc2 setContext [mod'] [] + -- + where support_module m = unlines [ + "module " ++ m ++ "( ", + " " ++ _String ++ ",", + " " ++ _show ++ ")", + "where", + "", + "import qualified Prelude as " ++ _P ++ " (String, Show(show))", + "", + "type " ++ _String ++ " = " ++ _P ++ ".String", + "", + _show ++ " :: " ++ _P ++ ".Show a => a -> " ++ _P ++ ".String", + _show ++ " = " ++ _P ++ ".show" + ] + where _String = altStringName m + _show = altShowName m + _P = altPreludeName m + +-- Call it when the support module is an active phantom module but has been +-- unloaded as a side effect by GHC (e.g. by calling GHC.loadTargets) +reinstallSupportModule :: MonadInterpreter m => m () +reinstallSupportModule = do pm <- fromState hintSupportModule + removePhantomModule pm + installSupportModule + +altStringName :: ModuleName -> String +altStringName mod_name = "String_" ++ mod_name + +altShowName :: ModuleName -> String +altShowName mod_name = "show_" ++ mod_name + +altPreludeName :: ModuleName -> String +altPreludeName mod_name = "Prelude_" ++ mod_name + +supportString :: MonadInterpreter m => m String +supportString = do mod_name <- fromState (pmName . hintSupportModule) + return $ concat [mod_name, ".", altStringName mod_name] + +supportShow :: MonadInterpreter m => m String +supportShow = do mod_name <- fromState (pmName . hintSupportModule) + return $ concat [mod_name, ".", altShowName mod_name] + +-- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED? +-- foreign import ccall "revertCAFs" rts_revertCAFs :: IO () diff --git a/src/Hint/Conversions.hs b/src/Hint/Conversions.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Conversions.hs @@ -0,0 +1,33 @@ +module Hint.Conversions ( + typeToString, kindToString, moduleToString, isSucceeded +) where + +import qualified Hint.GHC as GHC + +import Hint.Base + +-- --------- Types / Kinds ----------------------- + +typeToString :: MonadInterpreter m => GHC.Type -> m String +typeToString t + = do -- Unqualify necessary types + -- (i.e., do not expose internals) + unqual <- runGhc GHC.getPrintUnqual + withDynFlags $ \df -> + return $ GHC.showSDocForUser df unqual (GHC.pprTypeForUser t) + +kindToString :: MonadInterpreter m => GHC.Kind -> m String +kindToString k + = withDynFlags $ \df -> + return $ GHC.showSDoc df (GHC.pprTypeForUser k) + +-- ---------------- Modules -------------------------- + +moduleToString :: GHC.Module -> String +moduleToString = GHC.moduleNameString . GHC.moduleName + +-- ---------------- Misc ----------------------------- + +isSucceeded :: GHC.SuccessFlag -> Bool +isSucceeded GHC.Succeeded = True +isSucceeded GHC.Failed = False diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Eval.hs @@ -0,0 +1,77 @@ +module Hint.Eval ( + interpret, unsafeInterpret, + eval, runStmt, + parens +) where + +import qualified GHC.Exts (unsafeCoerce#) + +import Control.Exception + +import Data.Proxy +import Data.Typeable hiding (typeOf) + +import Hint.Base +import Hint.Context +import Hint.Parsers +import Hint.Util + +import qualified Hint.GHC as GHC + +-- | Evaluates an expression, given a witness for its monomorphic type. +interpret :: (MonadInterpreter m, Typeable a) => Proxy a -> String -> m a +interpret = unsafeInterpret . show . typeRep + +unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a +unsafeInterpret type_str expr = + do -- First, make sure the expression has no syntax errors, + -- for this is the only way we have to "intercept" this + -- kind of errors + failOnParseError parseExpr expr + -- + let expr_typesig = concat [parens expr, " :: ", type_str] + expr_val <- mayFail $ runGhc1 compileExpr expr_typesig + -- + return (GHC.Exts.unsafeCoerce# expr_val :: a) + +-- add a bogus Maybe, in order to use it with mayFail +compileExpr :: GHC.GhcMonad m => String -> m (Maybe GHC.HValue) +compileExpr = fmap Just . GHC.compileExpr + +-- | @eval expr@ will evaluate @show expr@. +-- It will succeed only if @expr@ has type t and there is a 'Show' +-- instance for t. +eval :: MonadInterpreter m => String -> m String +eval expr = do in_scope_show <- supportShow + in_scope_String <- supportString + let show_expr = unwords [in_scope_show, parens expr] + unsafeInterpret in_scope_String show_expr + +-- | 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. +-- Observe that if @s@ ends with a trailing comment, then @parens s@ would +-- be a malformed expression. The straightforward solution for this is to +-- put the closing parenthesis in a different line. However, now we are +-- messing with the layout rules and we don't know where @s@ is going to +-- be used! +-- Solution: @parens s = \"(let {foo =\n\" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@ +parens :: String -> String +parens s = concat ["(let {", foo, " =\n", s, "\n", + " ;} in ", foo, ")"] + where foo = safeBndFor s diff --git a/src/Hint/Extension.hs b/src/Hint/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Extension.hs @@ -0,0 +1,509 @@ +-- this module was automatically generated. do not edit! +-- edit util/mk_extensions_mod.hs instead +module Hint.Extension ( + Extension(..), supportedExtensions, availableExtensions, asExtension +) where + +import qualified Hint.GHC as GHC + +supportedExtensions :: [String] +supportedExtensions = map f GHC.xFlags + where + f = GHC.flagSpecName + +-- | List of the extensions known by the interpreter. +availableExtensions :: [Extension] +availableExtensions = map asExtension supportedExtensions + +asExtension :: String -> Extension +asExtension s = if isKnown s + then read s + else let no_s = "No" ++ s + in if isKnown no_s then read no_s + else UnknownExtension s + where isKnown e = e `elem` map show knownExtensions + +-- | This represents language extensions beyond Haskell 98 +-- that are supported by GHC (it was taken from +-- Cabal's @Language.Haskell.Extension@) +data Extension = OverlappingInstances + | UndecidableInstances + | IncoherentInstances + | DoRec + | RecursiveDo + | ParallelListComp + | MultiParamTypeClasses + | MonomorphismRestriction + | FunctionalDependencies + | Rank2Types + | RankNTypes + | PolymorphicComponents + | ExistentialQuantification + | ScopedTypeVariables + | PatternSignatures + | ImplicitParams + | FlexibleContexts + | FlexibleInstances + | EmptyDataDecls + | CPP + | KindSignatures + | BangPatterns + | TypeSynonymInstances + | TemplateHaskell + | ForeignFunctionInterface + | Arrows + | Generics + | ImplicitPrelude + | NamedFieldPuns + | PatternGuards + | GeneralizedNewtypeDeriving + | ExtensibleRecords + | RestrictedTypeSynonyms + | HereDocuments + | MagicHash + | TypeFamilies + | StandaloneDeriving + | UnicodeSyntax + | UnliftedFFITypes + | InterruptibleFFI + | CApiFFI + | LiberalTypeSynonyms + | TypeOperators + | RecordWildCards + | RecordPuns + | DisambiguateRecordFields + | TraditionalRecordSyntax + | OverloadedStrings + | GADTs + | GADTSyntax + | MonoPatBinds + | RelaxedPolyRec + | ExtendedDefaultRules + | UnboxedTuples + | DeriveDataTypeable + | DeriveGeneric + | DefaultSignatures + | InstanceSigs + | ConstrainedClassMethods + | PackageImports + | ImpredicativeTypes + | NewQualifiedOperators + | PostfixOperators + | QuasiQuotes + | TransformListComp + | MonadComprehensions + | ViewPatterns + | XmlSyntax + | RegularPatterns + | TupleSections + | GHCForeignImportPrim + | NPlusKPatterns + | DoAndIfThenElse + | MultiWayIf + | LambdaCase + | RebindableSyntax + | ExplicitForAll + | DatatypeContexts + | MonoLocalBinds + | DeriveFunctor + | DeriveTraversable + | DeriveFoldable + | NondecreasingIndentation + | SafeImports + | Safe + | Trustworthy + | Unsafe + | ConstraintKinds + | PolyKinds + | DataKinds + | ParallelArrays + | RoleAnnotations + | OverloadedLists + | EmptyCase + | AutoDeriveTypeable + | NegativeLiterals + | BinaryLiterals + | NumDecimals + | NullaryTypeClasses + | ExplicitNamespaces + | AllowAmbiguousTypes + | JavaScriptFFI + | PatternSynonyms + | PartialTypeSignatures + | NamedWildCards + | DeriveAnyClass + | DeriveLift + | StaticPointers + | StrictData + | Strict + | ApplicativeDo + | DuplicateRecordFields + | TypeApplications + | TypeInType + | UndecidableSuperClasses + | MonadFailDesugaring + | TemplateHaskellQuotes + | OverloadedLabels + | TypeFamilyDependencies + | NoOverlappingInstances + | NoUndecidableInstances + | NoIncoherentInstances + | NoDoRec + | NoRecursiveDo + | NoParallelListComp + | NoMultiParamTypeClasses + | NoMonomorphismRestriction + | NoFunctionalDependencies + | NoRank2Types + | NoRankNTypes + | NoPolymorphicComponents + | NoExistentialQuantification + | NoScopedTypeVariables + | NoPatternSignatures + | NoImplicitParams + | NoFlexibleContexts + | NoFlexibleInstances + | NoEmptyDataDecls + | NoCPP + | NoKindSignatures + | NoBangPatterns + | NoTypeSynonymInstances + | NoTemplateHaskell + | NoForeignFunctionInterface + | NoArrows + | NoGenerics + | NoImplicitPrelude + | NoNamedFieldPuns + | NoPatternGuards + | NoGeneralizedNewtypeDeriving + | NoExtensibleRecords + | NoRestrictedTypeSynonyms + | NoHereDocuments + | NoMagicHash + | NoTypeFamilies + | NoStandaloneDeriving + | NoUnicodeSyntax + | NoUnliftedFFITypes + | NoInterruptibleFFI + | NoCApiFFI + | NoLiberalTypeSynonyms + | NoTypeOperators + | NoRecordWildCards + | NoRecordPuns + | NoDisambiguateRecordFields + | NoTraditionalRecordSyntax + | NoOverloadedStrings + | NoGADTs + | NoGADTSyntax + | NoMonoPatBinds + | NoRelaxedPolyRec + | NoExtendedDefaultRules + | NoUnboxedTuples + | NoDeriveDataTypeable + | NoDeriveGeneric + | NoDefaultSignatures + | NoInstanceSigs + | NoConstrainedClassMethods + | NoPackageImports + | NoImpredicativeTypes + | NoNewQualifiedOperators + | NoPostfixOperators + | NoQuasiQuotes + | NoTransformListComp + | NoMonadComprehensions + | NoViewPatterns + | NoXmlSyntax + | NoRegularPatterns + | NoTupleSections + | NoGHCForeignImportPrim + | NoNPlusKPatterns + | NoDoAndIfThenElse + | NoMultiWayIf + | NoLambdaCase + | NoRebindableSyntax + | NoExplicitForAll + | NoDatatypeContexts + | NoMonoLocalBinds + | NoDeriveFunctor + | NoDeriveTraversable + | NoDeriveFoldable + | NoNondecreasingIndentation + | NoSafeImports + | NoSafe + | NoTrustworthy + | NoUnsafe + | NoConstraintKinds + | NoPolyKinds + | NoDataKinds + | NoParallelArrays + | NoRoleAnnotations + | NoOverloadedLists + | NoEmptyCase + | NoAutoDeriveTypeable + | NoNegativeLiterals + | NoBinaryLiterals + | NoNumDecimals + | NoNullaryTypeClasses + | NoExplicitNamespaces + | NoAllowAmbiguousTypes + | NoJavaScriptFFI + | NoPatternSynonyms + | NoPartialTypeSignatures + | NoNamedWildCards + | NoDeriveAnyClass + | NoDeriveLift + | NoStaticPointers + | NoStrictData + | NoStrict + | NoApplicativeDo + | NoDuplicateRecordFields + | NoTypeApplications + | NoTypeInType + | NoUndecidableSuperClasses + | NoMonadFailDesugaring + | NoTemplateHaskellQuotes + | NoOverloadedLabels + | NoTypeFamilyDependencies + | UnknownExtension String + deriving (Eq, Show, Read) + +knownExtensions :: [Extension] +knownExtensions = [OverlappingInstances, + UndecidableInstances, + IncoherentInstances, + DoRec, + RecursiveDo, + ParallelListComp, + MultiParamTypeClasses, + MonomorphismRestriction, + FunctionalDependencies, + Rank2Types, + RankNTypes, + PolymorphicComponents, + ExistentialQuantification, + ScopedTypeVariables, + PatternSignatures, + ImplicitParams, + FlexibleContexts, + FlexibleInstances, + EmptyDataDecls, + CPP, + KindSignatures, + BangPatterns, + TypeSynonymInstances, + TemplateHaskell, + ForeignFunctionInterface, + Arrows, + Generics, + ImplicitPrelude, + NamedFieldPuns, + PatternGuards, + GeneralizedNewtypeDeriving, + ExtensibleRecords, + RestrictedTypeSynonyms, + HereDocuments, + MagicHash, + TypeFamilies, + StandaloneDeriving, + UnicodeSyntax, + UnliftedFFITypes, + InterruptibleFFI, + CApiFFI, + LiberalTypeSynonyms, + TypeOperators, + RecordWildCards, + RecordPuns, + DisambiguateRecordFields, + TraditionalRecordSyntax, + OverloadedStrings, + GADTs, + GADTSyntax, + MonoPatBinds, + RelaxedPolyRec, + ExtendedDefaultRules, + UnboxedTuples, + DeriveDataTypeable, + DeriveGeneric, + DefaultSignatures, + InstanceSigs, + ConstrainedClassMethods, + PackageImports, + ImpredicativeTypes, + NewQualifiedOperators, + PostfixOperators, + QuasiQuotes, + TransformListComp, + MonadComprehensions, + ViewPatterns, + XmlSyntax, + RegularPatterns, + TupleSections, + GHCForeignImportPrim, + NPlusKPatterns, + DoAndIfThenElse, + MultiWayIf, + LambdaCase, + RebindableSyntax, + ExplicitForAll, + DatatypeContexts, + MonoLocalBinds, + DeriveFunctor, + DeriveTraversable, + DeriveFoldable, + NondecreasingIndentation, + SafeImports, + Safe, + Trustworthy, + Unsafe, + ConstraintKinds, + PolyKinds, + DataKinds, + ParallelArrays, + RoleAnnotations, + OverloadedLists, + EmptyCase, + AutoDeriveTypeable, + NegativeLiterals, + BinaryLiterals, + NumDecimals, + NullaryTypeClasses, + ExplicitNamespaces, + AllowAmbiguousTypes, + JavaScriptFFI, + PatternSynonyms, + PartialTypeSignatures, + NamedWildCards, + DeriveAnyClass, + DeriveLift, + StaticPointers, + StrictData, + Strict, + ApplicativeDo, + DuplicateRecordFields, + TypeApplications, + TypeInType, + UndecidableSuperClasses, + MonadFailDesugaring, + TemplateHaskellQuotes, + OverloadedLabels, + TypeFamilyDependencies, + NoOverlappingInstances, + NoUndecidableInstances, + NoIncoherentInstances, + NoDoRec, + NoRecursiveDo, + NoParallelListComp, + NoMultiParamTypeClasses, + NoMonomorphismRestriction, + NoFunctionalDependencies, + NoRank2Types, + NoRankNTypes, + NoPolymorphicComponents, + NoExistentialQuantification, + NoScopedTypeVariables, + NoPatternSignatures, + NoImplicitParams, + NoFlexibleContexts, + NoFlexibleInstances, + NoEmptyDataDecls, + NoCPP, + NoKindSignatures, + NoBangPatterns, + NoTypeSynonymInstances, + NoTemplateHaskell, + NoForeignFunctionInterface, + NoArrows, + NoGenerics, + NoImplicitPrelude, + NoNamedFieldPuns, + NoPatternGuards, + NoGeneralizedNewtypeDeriving, + NoExtensibleRecords, + NoRestrictedTypeSynonyms, + NoHereDocuments, + NoMagicHash, + NoTypeFamilies, + NoStandaloneDeriving, + NoUnicodeSyntax, + NoUnliftedFFITypes, + NoInterruptibleFFI, + NoCApiFFI, + NoLiberalTypeSynonyms, + NoTypeOperators, + NoRecordWildCards, + NoRecordPuns, + NoDisambiguateRecordFields, + NoTraditionalRecordSyntax, + NoOverloadedStrings, + NoGADTs, + NoGADTSyntax, + NoMonoPatBinds, + NoRelaxedPolyRec, + NoExtendedDefaultRules, + NoUnboxedTuples, + NoDeriveDataTypeable, + NoDeriveGeneric, + NoDefaultSignatures, + NoInstanceSigs, + NoConstrainedClassMethods, + NoPackageImports, + NoImpredicativeTypes, + NoNewQualifiedOperators, + NoPostfixOperators, + NoQuasiQuotes, + NoTransformListComp, + NoMonadComprehensions, + NoViewPatterns, + NoXmlSyntax, + NoRegularPatterns, + NoTupleSections, + NoGHCForeignImportPrim, + NoNPlusKPatterns, + NoDoAndIfThenElse, + NoMultiWayIf, + NoLambdaCase, + NoRebindableSyntax, + NoExplicitForAll, + NoDatatypeContexts, + NoMonoLocalBinds, + NoDeriveFunctor, + NoDeriveTraversable, + NoDeriveFoldable, + NoNondecreasingIndentation, + NoSafeImports, + NoSafe, + NoTrustworthy, + NoUnsafe, + NoConstraintKinds, + NoPolyKinds, + NoDataKinds, + NoParallelArrays, + NoRoleAnnotations, + NoOverloadedLists, + NoEmptyCase, + NoAutoDeriveTypeable, + NoNegativeLiterals, + NoBinaryLiterals, + NoNumDecimals, + NoNullaryTypeClasses, + NoExplicitNamespaces, + NoAllowAmbiguousTypes, + NoJavaScriptFFI, + NoPatternSynonyms, + NoPartialTypeSignatures, + NoNamedWildCards, + NoDeriveAnyClass, + NoDeriveLift, + NoStaticPointers, + NoStrictData, + NoStrict, + NoApplicativeDo, + NoDuplicateRecordFields, + NoTypeApplications, + NoTypeInType, + NoUndecidableSuperClasses, + NoMonadFailDesugaring, + NoTemplateHaskellQuotes, + NoOverloadedLabels, + NoTypeFamilyDependencies + ] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Hint/GHC.hs @@ -0,0 +1,46 @@ +module Hint.GHC ( + 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, + withPprStyle, defaultErrStyle) + +import ErrUtils as X (mkLocMessage, pprErrMsgBagWithLoc, MsgDoc) -- 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 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 PprTyThing as X (pprTypeForUser) +import SrcLoc as X (mkRealSrcLoc) + +import ConLike as X (ConLike(RealDataCon)) + +import DynFlags as X (addWay', Way(..), dynamicGhc) + +type Message = MsgDoc + +#if __GLASGOW_HASKELL__ < 804 +type GhcPs = RdrName + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries = id +#endif diff --git a/src/Hint/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 new file mode 100644 --- /dev/null +++ b/src/Hint/InterpreterT.hs @@ -0,0 +1,205 @@ +module Hint.InterpreterT ( + InterpreterT, Interpreter, + runInterpreter, runInterpreterWithArgs, runInterpreterWithArgsLibdir, + MultipleInstancesNotAllowed(..) +) where + +import Control.Applicative +import Prelude + +import Hint.Base +import Hint.Context +import Hint.Configuration +import Hint.Extension + +import Control.Monad.Reader +import Control.Monad.Catch as MC + +import Data.Typeable (Typeable) +import Control.Concurrent.MVar +import System.IO.Unsafe (unsafePerformIO) + +import Data.IORef +import Data.Maybe + +import qualified GHC.Paths + +import qualified Hint.GHC as GHC + +type Interpreter = InterpreterT IO + +newtype InterpreterT m a = InterpreterT { + unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a + } + deriving (Functor, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) + +execute :: (MonadIO m, MonadMask m) + => String + -> InterpreterSession + -> InterpreterT m a + -> m (Either InterpreterError a) +execute libdir s = try + . GHC.runGhcT (Just libdir) + . flip runReaderT s + . unInterpreterT + +instance MonadTrans InterpreterT where + lift = InterpreterT . lift . lift + +runGhcImpl :: (MonadIO m, MonadMask m) + => RunGhc (InterpreterT m) a +runGhcImpl a = + InterpreterT (lift a) + `catches` + [Handler (\(e :: GHC.SourceError) -> do + dynFlags <- runGhc GHC.getSessionDynFlags + throwM $ compilationError dynFlags e) + ,Handler (\(e :: GHC.GhcApiError) -> throwM $ GhcException $ show e) + ,Handler (\(e :: GHC.GhcException) -> throwM $ GhcException $ showGhcEx e) + ] + where + compilationError dynFlags + = WontCompile + . map (GhcError . GHC.showSDoc dynFlags) + . GHC.pprErrMsgBagWithLoc + . GHC.srcErrorMessages + +showGhcEx :: GHC.GhcException -> String +showGhcEx = flip GHC.showGhcException "" + +-- ================= Executing the interpreter ================== + +initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m) + => [String] + -> InterpreterT m () +initialize args = + do log_handler <- fromSession ghcErrLogger + -- Set a custom log handler, to intercept error messages :S + df0 <- runGhc GHC.getSessionDynFlags + + let df1 = configureDynFlags df0 + (df2, extra) <- runGhc2 parseDynamicFlags df1 args + unless (null extra) $ + throwM $ UnknownError (concat [ "flags: '" + , unwords extra + , "' not recognized"]) + + -- Observe that, setSessionDynFlags loads info on packages + -- 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 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) + let defExts = map getOptVal supportedExtensions + + onState (\s -> s{defaultExts = defExts}) + + reset + +-- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. +-- +-- 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) + => [String] + -> InterpreterT m a + -> m (Either InterpreterError a) +runInterpreterWithArgs args = runInterpreterWithArgsLibdir args GHC.Paths.libdir + +runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m) + => [String] + -> String + -> InterpreterT m a + -> m (Either InterpreterError a) +runInterpreterWithArgsLibdir args libdir action = + ifInterpreterNotRunning $ + do s <- newInterpreterSession `MC.catch` rethrowGhcException + execute libdir s (initialize args >> action `finally` cleanSession) + where rethrowGhcException = throwM . GhcException . showGhcEx + newInterpreterSession = newSessionData () + cleanSession = + do cleanPhantomModules + +{-# 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) + +-- | The installed version of ghc is not thread-safe. This exception +-- is thrown whenever you try to execute @runInterpreter@ while another +-- instance is already running. +data MultipleInstancesNotAllowed = MultipleInstancesNotAllowed deriving Typeable + +instance Exception MultipleInstancesNotAllowed + +instance Show MultipleInstancesNotAllowed where + show _ = "This version of GHC is not thread-safe," ++ + "can't safely run two instances of the interpreter simultaneously" + +initialState :: InterpreterState +initialState = St { + activePhantoms = [], + zombiePhantoms = [], +#if defined(NEED_PHANTOM_DIRECTORY) + phantomDirectory = Nothing, +#endif + hintSupportModule = error "No support module loaded!", + importQualHackMod = Nothing, + qualImports = [], + defaultExts = error "defaultExts missing!", + configuration = defaultConf + } + +newSessionData :: MonadIO m => a -> m (SessionData a) +newSessionData a = + do initial_state <- liftIO $ newIORef initialState + ghc_err_list_ref <- liftIO $ newIORef [] + return SessionData { + internalState = initial_state, + versionSpecific = a, + ghcErrListRef = ghc_err_list_ref, + ghcErrLogger = mkLogHandler ghc_err_list_ref + } + +mkLogHandler :: IORef [GhcError] -> GhcErrLogger +mkLogHandler r df _ _ src style msg = + let renderErrMsg = GHC.showSDoc df + errorEntry = mkGhcError renderErrMsg src style msg + in modifyIORef r (errorEntry :) + +mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError +mkGhcError render src_span style msg = GhcError{errMsg = niceErrMsg} + where niceErrMsg = render . GHC.withPprStyle style $ + GHC.mkLocMessage GHC.SevError src_span msg + +-- The MonadInterpreter instance + +instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where + fromSession f = InterpreterT $ fmap f ask + -- + modifySessionRef target f = + do ref <- fromSession target + liftIO $ atomicModifyIORef ref (\a -> (f a, a)) + -- + runGhc = runGhcImpl + +instance (Monad m) => Applicative (InterpreterT m) where + pure = return + (<*>) = ap diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Parsers.hs @@ -0,0 +1,67 @@ +module Hint.Parsers where + +import Prelude hiding (span) + +import Hint.Base + +import Control.Monad.Trans (liftIO) + +import qualified Hint.GHC as GHC + +data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message + +parseExpr :: MonadInterpreter m => String -> m ParseResult +parseExpr = runParser GHC.parseStmt + +parseType :: MonadInterpreter m => String -> m ParseResult +parseType = runParser GHC.parseType + +runParser :: MonadInterpreter m => GHC.P a -> String -> m ParseResult +runParser parser expr = + do dyn_fl <- runGhc GHC.getSessionDynFlags + -- + buf <- (return . GHC.stringToStringBuffer) expr + -- + -- ghc >= 7 panics if noSrcLoc is given + let srcLoc = GHC.mkRealSrcLoc (GHC.fsLit "") 1 1 + let parse_res = GHC.unP parser (GHC.mkPState dyn_fl buf srcLoc) + -- + case parse_res of + GHC.POk{} -> return ParseOk + -- +#if __GLASGOW_HASKELL__ >= 804 + GHC.PFailed _ span err +#else + GHC.PFailed span err +#endif + -> return (ParseError span err) + +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 + ParseOk -> return (Just ()) + -- + ParseError span err -> + do -- parsing failed, so we report it just as all + -- other errors get reported.... + logger <- fromSession ghcErrLogger + dflags <- runGhc GHC.getSessionDynFlags + let logger' = logger dflags + errStyle = GHC.defaultErrStyle dflags + liftIO $ logger' + GHC.NoReason + GHC.SevError + span + errStyle + err + -- + -- behave like the rest of the GHC API functions + -- do on error... + return Nothing diff --git a/src/Hint/Reflection.hs b/src/Hint/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Reflection.hs @@ -0,0 +1,67 @@ +module Hint.Reflection ( + ModuleElem(..), Id, name, children, + getModuleExports, +) where + +import Data.List +import Data.Maybe + +import Hint.Base +import qualified Hint.GHC as GHC + +-- | An Id for a class, a type constructor, a data constructor, a binding, etc +type Id = String + +data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id] + deriving (Read, Show, Eq) + +name :: ModuleElem -> Id +name (Fun f) = f +name (Class c _) = c +name (Data d _) = d + +children :: ModuleElem -> [Id] +children (Fun _) = [] +children (Class _ ms) = ms +children (Data _ dcs) = dcs + +-- | Gets an abstract representation of all the entities exported by the module. +-- It is similar to the @:browse@ command in GHCi. +getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem] +getModuleExports mn = + do module_ <- findModule mn + mod_info <- mayFail $ runGhc1 GHC.getModuleInfo module_ + exports <- mapM (runGhc1 GHC.lookupName) (GHC.modInfoExports mod_info) + dflags <- runGhc GHC.getSessionDynFlags + -- + return $ asModElemList dflags (catMaybes exports) + +asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem] +asModElemList df xs = concat [ + 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] + alsoIn es = (`elem` map name es) + +asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem +asModElem df (GHC.AnId f) = Fun $ getUnqualName df f +asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc +asModElem df (GHC.ATyCon tc) = + if GHC.isClassTyCon tc + then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc) + else Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc) +asModElem _ _ = error "asModElem: can't happen!" + +getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String +getUnqualName dfs = GHC.showSDocUnqual dfs . GHC.pprParenSymName diff --git a/src/Hint/Typecheck.hs b/src/Hint/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Typecheck.hs @@ -0,0 +1,84 @@ +module Hint.Typecheck ( + typeOf, typeChecks, kindOf, normalizeType, onCompilationError, typeChecksWithDetails +) where + +import Control.Monad.Catch + +import Hint.Base +import Hint.Parsers +import Hint.Conversions + +import qualified Hint.GHC as GHC + +-- | Returns a string representation of the type of the expression. +typeOf :: MonadInterpreter m => String -> m String +typeOf expr = + do -- First, make sure the expression has no syntax errors, + -- for this is the only way we have to "intercept" this + -- kind of errors + failOnParseError parseExpr expr + -- + ty <- mayFail $ runGhc1 exprType expr + -- + 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 +kindOf type_expr = + do -- First, make sure the expression has no syntax errors, + -- for this is the only way we have to "intercept" this + -- kind of errors + failOnParseError parseType type_expr + -- + (_, kind) <- mayFail $ runGhc1 typeKind type_expr + -- + kindToString kind + +-- | Returns a string representation of the normalized type expression. +-- This is what the @:kind!@ GHCi command prints after @=@. +normalizeType :: MonadInterpreter m => String -> m String +normalizeType type_expr = + do -- First, make sure the expression has no syntax errors, + -- for this is the only way we have to "intercept" this + -- kind of errors + failOnParseError parseType type_expr + -- + (ty, _) <- mayFail $ runGhc1 typeKind type_expr + -- + typeToString ty + +-- add a bogus Maybe, in order to use it with mayFail +exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type) +#if __GLASGOW_HASKELL__ < 802 +exprType = fmap Just . GHC.exprType +#else +exprType = fmap Just . GHC.exprType GHC.TM_Inst +#endif + +-- add a bogus Maybe, in order to use it with mayFail +typeKind :: GHC.GhcMonad m => String -> m (Maybe (GHC.Type, GHC.Kind)) +typeKind = fmap Just . GHC.typeKind True + +onCompilationError :: MonadInterpreter m + => ([GhcError] -> m a) + -> (InterpreterError -> m a) +onCompilationError recover interp_error + = case interp_error of + WontCompile errs -> recover errs + otherErr -> throwM otherErr diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Util.hs @@ -0,0 +1,27 @@ +module Hint.Util where + +import Data.Char + +type Expr = String + +-- @safeBndFor expr@ generates a name @e@ such that it does not +-- occur free in @expr@ and, thus, it is safe to write something +-- like @e = expr@ (otherwise, it will get accidentally bound). +-- This ought to do the trick: observe that @safeBndFor expr@ +-- contains more digits than @expr@ and, thus, cannot occur inside +-- @expr@. +safeBndFor :: Expr -> String +safeBndFor expr = "e_1" ++ filter isDigit expr + +partition :: (a -> Bool) -> [a] -> ([a], [a]) +partition prop = foldr (select prop) ([],[]) + where select p x ~(ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + +partitionEither :: [Either a b] -> ([a],[b]) +partitionEither [] = ([],[]) +partitionEither (Left a:xs) = let (ls,rs) = partitionEither xs in (a:ls,rs) +partitionEither (Right b:xs) = let (ls,rs) = partitionEither xs in (ls,b:rs) + +quote :: String -> String +quote s = concat ["'", s, "'"] diff --git a/src/Language/Haskell/Interpreter.hs b/src/Language/Haskell/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Interpreter +-- License : BSD-style +-- +-- Maintainer : mvdan@mvdan.cc +-- Stability : experimental +-- Portability : non-portable (GHC API) +-- +-- A Haskell interpreter built on top of the GHC API +----------------------------------------------------------------------------- +module Language.Haskell.Interpreter( + -- * The interpreter monad transformer + MonadInterpreter(..), InterpreterT, Interpreter, + -- ** Running the interpreter + runInterpreter, + -- ** Interpreter options + Option, OptionVal((:=)), + get, set, + languageExtensions, availableExtensions, Extension(..), + installedModulesInScope, searchPath, + + -- ** Context handling + ModuleName, isModuleInterpreted, + ModuleImport(..), ModuleQualification(..), ImportList(..), + loadModules, getLoadedModules, setTopLevelModules, + setImports, setImportsQ, setImportsF, + reset, + -- ** Module querying + ModuleElem(..), Id, name, children, + getModuleExports, + -- ** Annotations + -- In the snippets below we use \'LBRACE\' and \'RBRACE\' + -- to mean \'{\' and \'}\' respectively. We cannot put the + -- pragmas inline in the code since GHC scarfs them up. + getModuleAnnotations, getValAnnotations, + -- ** Type inference + typeChecksWithDetails, + typeOf, typeChecks, kindOf, normalizeType, + -- ** Evaluation + interpret, eval, runStmt, + -- * Error handling + InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), + -- * Miscellaneous + ghcVersion, parens, + module Control.Monad.Trans +) where + +import Hint.Base +import Hint.Annotations +import Hint.InterpreterT +import Hint.Configuration +import Hint.Context +import Hint.Reflection +import Hint.Typecheck +import Hint.Eval + +import Control.Monad.Trans diff --git a/src/Language/Haskell/Interpreter/Extension.hs b/src/Language/Haskell/Interpreter/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/Extension.hs @@ -0,0 +1,5 @@ +module Language.Haskell.Interpreter.Extension ( + module Hint.Extension +) where + +import Hint.Extension diff --git a/src/Language/Haskell/Interpreter/Unsafe.hs b/src/Language/Haskell/Interpreter/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Interpreter/Unsafe.hs @@ -0,0 +1,44 @@ +module Language.Haskell.Interpreter.Unsafe ( + unsafeSetGhcOption, unsafeRunInterpreterWithArgs, unsafeRunInterpreterWithArgsLibdir, + unsafeInterpret +) where + +import Control.Monad.Trans +import Control.Monad.Catch + +import Hint.Base +import Hint.Eval +import Hint.Configuration +import Hint.InterpreterT + +-- | Set a GHC option for the current session, +-- eg. @unsafeSetGhcOption \"-XNoMonomorphismRestriction\"@. +-- +-- Warning: Some options may interact badly with the Interpreter. +unsafeSetGhcOption :: MonadInterpreter m => String -> m () +unsafeSetGhcOption = setGhcOption + +-- | Executes the interpreter, setting the args as though they were +-- command-line args. In particular, this means args that have no +-- effect with :set in ghci might function properly from this +-- context. +-- +-- Warning: Some options may interact badly with the Interpreter. +unsafeRunInterpreterWithArgs :: (MonadMask m, MonadIO m) + => [String] + -> InterpreterT m a + -> m (Either InterpreterError a) +unsafeRunInterpreterWithArgs = runInterpreterWithArgs + +-- | A variant of @unsafeRunInterpreterWithArgs@ which also lets you +-- specify the folder in which the GHC bootstrap libraries (base, +-- 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". +unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m) + => [String] + -> String + -> InterpreterT m a + -> m (Either InterpreterError a) +unsafeRunInterpreterWithArgsLibdir = runInterpreterWithArgsLibdir diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs new file mode 100644 --- /dev/null +++ b/unit-tests/run-unit-tests.hs @@ -0,0 +1,360 @@ +module Main (main) where + +import Prelude hiding (catch) + +import Control.Exception.Extensible (ArithException(..), AsyncException(UserInterrupt)) +import Control.Monad.Catch as MC + +import Control.Monad (liftM, when, void, (>=>)) + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar + +import Data.IORef +import Data.Proxy + +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 + +import Language.Haskell.Interpreter + +test_reload_modified :: TestCase +test_reload_modified = TestCase "reload_modified" [mod_file] $ do + liftIO $ writeFile mod_file mod_v1 + f_v1 <- get_f + -- + liftIO $ writeFile mod_file mod_v2 + f_v2 <- get_f + -- + liftIO $ (f_v1 5, f_v2 5) @?= (5, 6) + -- + where mod_name = "TEST_ReloadModified" + mod_file = mod_name ++ ".hs" + -- + mod_v1 = unlines ["module " ++ mod_name, + "where", + "f :: Int -> Int", + "f = id"] + mod_v2 = unlines ["module " ++ mod_name, + "where", + "f :: Int -> Int", + "f = (1 +)"] + -- + get_f = do loadModules [mod_file] + setTopLevelModules [mod_name] + interpret (Proxy :: Proxy (Int -> Int)) "f" + +test_lang_exts :: TestCase +test_lang_exts = TestCase "lang_exts" [mod_file] $ do + liftIO $ writeFile mod_file "data T where T :: T" + fails do_load @@? "first time, it shouldn't load" + -- + set [languageExtensions := [GADTs]] + succeeds do_load @@? "now, it should load" + -- + set [languageExtensions := []] + fails do_load @@? "it shouldn't load, again" + -- + where mod_name = "TEST_LangExts" + mod_file = mod_name ++ ".hs" + -- + do_load = loadModules [mod_name] + +test_work_in_main :: TestCase +test_work_in_main = TestCase "work_in_main" [mod_file] $ do + liftIO $ writeFile mod_file "f = id" + loadModules [mod_file] + setTopLevelModules ["Main"] + setImportsQ [("Prelude", Nothing), + ("Data.Maybe", Just "Mb")] + -- + typeOf "f $ (1 + 1 :: Int)" @@?= "Int" + eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]" + interpret Proxy "f $ 1 == 2" @@?= False + -- + where mod_file = "TEST_WorkInMain.hs" + +test_priv_syms_in_scope :: TestCase +test_priv_syms_in_scope = TestCase "private_syms_in_scope" [mod_file] $ do + -- must set to True, otherwise won't work with + -- ghc 6.8 + set [installedModulesInScope := True] + liftIO $ writeFile mod_file mod_text + loadModules [mod_file] + setTopLevelModules ["T"] + typeChecks "g" @@? "g is hidden" + where mod_text = unlines ["module T(f) where", "f = g", "g = id"] + mod_file = "TEST_PrivateSymbolsInScope.hs" + +test_comments_in_expr :: TestCase +test_comments_in_expr = TestCase "comments_in_expr" [] $ do + setImports ["Prelude"] + let expr = "length $ concat [[1,2],[3]] -- bla" + typeChecks expr @@? "comment on expression" + _ <- eval expr + _ <- interpret (Proxy :: Proxy Int) expr + return () + +test_qual_import :: TestCase +test_qual_import = TestCase "qual_import" [] $ do + setImportsQ [("Prelude", Nothing), + ("Data.Map", Just "M")] + 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 "()" @@?= "()" + +test_eval_layout :: TestCase +test_eval_layout = TestCase "eval_layout" [] $ eval layout_expr @@?= "10" + where layout_expr = unlines ["let x = let y = 10", + " in y", + "in x"] + +test_show_in_scope :: TestCase +test_show_in_scope = TestCase "show_in_scope" [] $ do + setImports ["Prelude"] + eval "show ([] :: String)" @@?= show (show "") + +test_installed_not_in_scope :: TestCase +test_installed_not_in_scope = TestCase "installed_not_in_scope" [] $ do + b <- get installedModulesInScope + succeeds action @@?= b + set [installedModulesInScope := False] + fails action @@? "now must be out of scope" + set [installedModulesInScope := True] + succeeds action @@? "must be in scope again" + where action = typeOf "Data.Map.singleton" + +test_search_path :: TestCase +test_search_path = + TestCase "search_path" files $ do + liftIO setup + fails (loadModules [mod_1]) @@? "mod_1 should not be in path (1)" + fails (loadModules [mod_2]) @@? "mod_2 should not be in path (1)" + -- + set [searchPath := [dir_1]] + succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (2)" + fails (loadModules [mod_2]) @@? "mod_2 should not be in path (2)" + -- + set [searchPath := [dir_2]] + fails (loadModules [mod_1]) @@? "mod_1 should not be in path (3)" + succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (3)" + -- + set [searchPath := [dir_1,dir_2]] + succeeds (loadModules [mod_1]) @@? "mod_1 should be in path (4)" + succeeds (loadModules [mod_2]) @@? "mod_2 should be in path (4)" + where dir_1 = "search_path_test_dir_1" + mod_1 = "M1" + file_1 = dir_1 mod_1 <.> "hs" + dir_2 = "search_path_test_dir_2" + mod_2 = "M2" + file_2 = dir_2 mod_2 <.> "hs" + files = [file_1, file_2, dir_1, dir_2] + setup = do createDirectory dir_1 + createDirectory dir_2 + writeFile file_1 $ + unlines ["module " ++ mod_1, + "where", + "x :: Int", + "x = 42"] + writeFile file_2 $ + unlines ["module " ++ mod_2, + "where", + "y :: Bool", + "y = False"] + +test_search_path_dot :: TestCase +test_search_path_dot = + TestCase "search_path_dot" [mod_file, dir] $ do + liftIO setup + succeeds (loadModules [mod1]) @@? "mod1 must be initially in path" + set [searchPath := [dir]] + succeeds (loadModules [mod1]) @@? "mod1 must be still in path" + -- + where dir = "search_path_dot_dir" + mod1 = "M1" + mod_file = mod1 <.> "hs" + setup = do createDirectory dir + writeFile mod_file $ + unlines ["x :: Int", "x = 42"] + +test_catch :: TestCase +test_catch = TestCase "catch" [] $ do + setImports ["Prelude"] + succeeds (action `catch` handler) @@? "catch failed" + where handler DivideByZero = return "catched" + handler e = throwM e + action = do s <- eval "1 `div` 0 :: Int" + return $! s + +test_only_one_instance :: TestCase +test_only_one_instance = TestCase "only_one_instance" [] $ liftIO $ do + r <- newEmptyMVar + let concurrent = runInterpreter (liftIO $ putMVar r False) + `catch` \MultipleInstancesNotAllowed -> + do liftIO $ putMVar r True + return $ Right () + _ <- forkIO $ Control.Monad.void concurrent + readMVar r @? "concurrent instance did not fail" + +test_normalize_type :: TestCase +test_normalize_type = TestCase "normalize_type" [mod_file] $ do + liftIO $ writeFile mod_file mod_text + loadModules [mod_file] + setTopLevelModules ["T"] + normalizeType "Foo Int" @@?= "()" + + where mod_text = unlines ["{-# LANGUAGE TypeFamilies #-}" + ,"module T where" + ,"type family Foo x" + ,"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 + ,test_installed_not_in_scope + ,test_priv_syms_in_scope + ,test_search_path + ,test_search_path_dot + ,test_catch + ,test_only_one_instance + ,test_normalize_type + ] + +ioTests :: [IOTestCase] +ioTests = [test_signal_handlers + ] + +main :: IO () +main = do -- run the tests... + c1 <- runTests False tests + c2 <- runIOTests False ioTests + -- then run again, but with sandboxing on... + c3 <- runTests True tests + c4 <- runIOTests True ioTests + -- + 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 + exitWith exit_code + -- `catch` (\_ -> exitWith (ExitFailure $ -1)) + +printInterpreterError :: InterpreterError -> IO () +printInterpreterError = hPrint stderr + +setSandbox :: Interpreter () +setSandbox = set [installedModulesInScope := False] + +(@@?) :: (HUnit.AssertionPredicable p, MonadIO m) => m p -> String -> m () +p @@? msg = do b <- p; liftIO (b @? msg) + +(@@?=) :: (Eq a, Show a, MonadIO m) => m a -> a -> m () +m_a @@?= b = do a <- m_a; liftIO (a @?= b) + +fails :: (MonadCatch m, MonadIO m) => m a -> m Bool +fails action = (action >> return False) `catchIE` (\_ -> return True) + where + catchIE :: MonadCatch m => m a -> (InterpreterError -> m a) -> m a + catchIE = MC.catch + +succeeds :: (MonadCatch m, MonadIO m) => m a -> m Bool +succeeds = liftM not . fails + +data IOTestCase = IOTestCase String [FilePath] ((Interpreter () -> IO (Either InterpreterError ())) -> IO (Either InterpreterError ())) + +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 <- test (\body -> runInterpreter + (when sandboxed setSandbox >> body)) + either (printInterpreterError >=> (fail . show)) + return r + removeIfExists f = do existsF <- doesFileExist f + if existsF + then removeFile f + else + 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)