hint-0.3.3.6/0000755000000000000000000000000012117644541011016 5ustar0000000000000000hint-0.3.3.6/AUTHORS0000644000000000000000000000034612117644541012071 0ustar0000000000000000Daniel Gorin Contributions from: Evan Laforge Gwern Branwen Jean Philippe Bernardy Austin Seipp Fernando Benavides Pasqualino Titto Assini Carl Howells Daniel Wagner Bryan O'Sullivan Conrad Parker Mark Wright Bertram Felgenhauer hint-0.3.3.6/Changes0000644000000000000000000000527312117644541012320 0ustar0000000000000000- ver 0.3.3.6 * Works again on GHC 7.2.x (thanks to Björn Peemöller) - ver 0.3.3.5 * Works on GHC 7.4.6 * Cleans up files for phantom modules that were left behind (thanks to Beltram Felgenhauer) - ver 0.3.3.4 * Works on GHC 7.4.1 - ver 0.3.3.3 * Works on GHC 7.2.1 - ver 0.3.3.2 * Supports GHC 7 - ver 0.3.3.1 * Instance declaration for Applicative (InterpreterT m) works with mtl-2 (requires Applicative m, this shouldn't break anything...) - ver 0.3.3.0 * add unsafeRunInterpreterWithArgs * check that only one instance of the interpreter is run at any time - ver 0.3.2.3 * Can be built against MonadCatchIO-mtl-0.3.x.x - ver 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) - ver 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 - ver 0.3.2.0 * Exports functions parens and isInterpretedModule * Experimental support for module annotations * Uses extensible-exceptions in order to provide a uniform interface accross different ghc versions * Provides an Applicative instance for IntepreterT * Adds an option to configurate the searchPath - ver 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. - ver 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) - ver 0.2.5 * setImportsQ added (modules can be imported both qualified and unqualified) - ver 0.2.4.1 * BUGFIX: No longer fails on expressions ending in a -- comment - ver 0.2.4 * setInstalledModsAreInScopeQualified added * Now depends on ghc-paths (no longer needs a custom cabal script) - ver 0.2.2 * setOptimizations added * Module Language.Haskell.Interpreter.GHC.Unsafe added (contains unsafeSetGhcOption) * unit tests now based on HUnit - ver 0.2.1 * BUGFIX: Module reloading was broken under 6.8 * GHC.GhcExceptions are catched and turned into InterpreterErrors - ver 0.2.0.1 * Adds the requirement cabal-version < 1.3 - ver 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 hint-0.3.3.6/hint.cabal0000644000000000000000000000673412117644541012756 0ustar0000000000000000name: hint version: 0.3.3.6 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, esentially, a huge subset of the GHC API wrapped in a simpler API. Works with GHC 6.10.x and 6.8.x (this version was not tested with GHC 6.6). synopsis: Runtime Haskell interpreter (GHC API wrapper) category: Language, Compilers/Interpreters license: BSD3 license-file: LICENSE author: Daniel Gorin maintainer: jcpetruzza@gmail.com homepage: http://darcsden.com/jcpetruzza/hint cabal-version: >= 1.2.3 build-type: Simple tested-with: GHC==6.8.3, GHC==6.10 extra-source-files: README AUTHORS Changes examples/example.hs examples/SomeModule.hs unit-tests/run-unit-tests.hs Library build-depends: haskell-src, ghc > 6.6, ghc-paths, mtl, filepath, utf8-string, extensible-exceptions, MonadCatchIO-mtl >= 0.3 if impl(ghc >= 6.8) { build-depends: random, directory if impl(ghc >= 6.10) { build-depends: base >= 4, base < 5, ghc-mtl >= 1.0.1.0, ghc-mtl < 1.1.0.0 -- this is to protect against the accidental selection -- of the completely unrelated ghc'c ghc-mtl package } else { build-depends: base >= 3, base < 4 } } else { -- ghc < 6.8 build-depends: utf8-string < 0.3 } if !os(windows) { build-depends: unix >= 2.2.0.0 } exposed-modules: Language.Haskell.Interpreter Language.Haskell.Interpreter.Extension Language.Haskell.Interpreter.Unsafe Language.Haskell.Interpreter.GHC Language.Haskell.Interpreter.GHC.Unsafe other-modules: Hint.GHC Hint.Base Hint.InterpreterT Hint.Compat Hint.Configuration Hint.Extension Hint.Context Hint.Conversions Hint.Eval Hint.Parsers Hint.Reflection Hint.Typecheck Hint.Sandbox Hint.SignalHandlers Hint.Util if impl(ghc >= 6.11) { other-modules: Hint.Annotations } hs-source-dirs: src ghc-options: -Wall -O2 extensions: CPP GeneralizedNewtypeDeriving MultiParamTypeClasses DeriveDataTypeable MagicHash TypeSynonymInstances FlexibleInstances FlexibleContexts FunctionalDependencies KindSignatures Rank2Types ScopedTypeVariables ExistentialQuantification PatternGuards hint-0.3.3.6/LICENSE0000644000000000000000000000271312117644541012026 0ustar0000000000000000Copyright 2007, Daniel Gorin. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author 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.hint-0.3.3.6/README0000644000000000000000000000117712117644541011704 0ustar0000000000000000=== Installation === To install locally: > runhaskell Setup.lhs configure --prefix=$HOME --user > runhaskell Setup.lhs build > runhaskell Setup.lhs haddock > runhaskell Setup.lhs install === Documentation === The library cames with haddock documentation you can build (see above). Also, check examples/example.hs to see a simple but comprehensive example (it must be run from the examples directory, since it expects to find the SomeModule.hs file located there). === Contact === Bug-reports, questions, suggestions and patches are all welcome. To get a copy of the darcs repository: darcs get http://darcsden.com/jcpetruzza/hint hint-0.3.3.6/Setup.lhs0000644000000000000000000000021212117644541012621 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMainWithHooks defaultUserHooks hint-0.3.3.6/examples/0000755000000000000000000000000012117644541012634 5ustar0000000000000000hint-0.3.3.6/examples/example.hs0000644000000000000000000000440512117644541014626 0ustar0000000000000000import Control.Monad import Language.Haskell.Interpreter main :: IO () main = do r <- runInterpreter testHint case r of Left err -> printInterpreterError err Right () -> putStrLn "that's all folks" -- observe that Interpreter () is an alias for InterpreterT IO () testHint :: Interpreter () testHint = do say "Load SomeModule.hs" loadModules ["SomeModule.hs"] -- 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")] -- 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 -- 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) -- say "We can also evaluate an expression; the result will be a string" let expr2 = "length $ concat [[f,g],[h]]" say $ concat ["e.g. eval ", show expr1] a <- eval expr2 say (show a) -- say "Or we can interpret it as a proper, say, int value!" a_int <- interpret expr2 (as :: Int) say (show a_int) -- 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) -- 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) -- 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 say :: String -> Interpreter () say = liftIO . putStrLn printInterpreterError :: InterpreterError -> IO () printInterpreterError e = putStrLn $ "Ups... " ++ (show e) hint-0.3.3.6/examples/SomeModule.hs0000644000000000000000000000007112117644541015237 0ustar0000000000000000module SomeModule(g, h) where f = head g = f [f] h = fhint-0.3.3.6/src/0000755000000000000000000000000012117644541011605 5ustar0000000000000000hint-0.3.3.6/src/Hint/0000755000000000000000000000000012117644541012507 5ustar0000000000000000hint-0.3.3.6/src/Hint/Annotations.hs0000644000000000000000000000403412117644541015341 0ustar0000000000000000-- - extract annotations from modules etc. with the GHC API. -- - requires GHC >= 6.11 -- -- austin seipp module Hint.Annotations ( getModuleAnnotations -- :: (Data a, MonadInterpreter m) => a -> String -> m [a] , getValAnnotations -- :: (Data a, MonadInterpreter m) => a -> String -> m [a] ) where import Control.Monad import Data.Data import Annotations import 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. -- -- For example, given: -- -- @ -- RBRACE-\# ANN module (1 :: Int) \#-LBRACE -- module SomeModule(g, h) where -- ... -- @ -- -- Then after using 'loadModule' to load SomeModule into scope: -- -- @ -- x <- getModuleAnnotations (as :: Int) "SomeModule" -- liftIO $ print x -- -- result is [1] -- @ getModuleAnnotations :: (Data a, MonadInterpreter m) => a -> String -> m [a] getModuleAnnotations _ x = do mods <- liftM 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 -- -- For example, given: -- -- @ -- module SomeModule(g, h) where -- -- LBRACE-\# ANN g (Just 1 :: Maybe Int) \#-RBRACE -- g = f [f] -- -- LBRACE-\# ANN h (Just 2 :: Maybe Int) \#-RBRACE -- h = f -- @ -- -- Then after using 'loadModule' to bring SomeModule into scope: -- -- @ -- x <- liftM concat $ mapM (getValAnnotations (as :: Maybe Int)) [\"g\",\"h\"] -- liftIO $ print x -- -- result is [Just 2, Just 1] -- @ -- -- This can also work on data constructors and types with annotations. 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) hint-0.3.3.6/src/Hint/Base.hs0000644000000000000000000001677412117644541013734 0ustar0000000000000000module Hint.Base ( MonadInterpreter(..), RunGhc, -- GhcError(..), InterpreterError(..), mayFail, -- InterpreterSession, SessionData(..), GhcErrLogger, InterpreterState(..), fromState, onState, InterpreterConfiguration(..), -- runGhc1, runGhc2, runGhc3, runGhc4, runGhc5, -- ModuleName, PhantomModule(..), findModule, moduleIsLoaded, -- ghcVersion ) where import Control.Monad.Error import Control.Monad.CatchIO import Data.IORef import Data.Dynamic import qualified Hint.GHC as GHC import Hint.Extension -- | Version of the underlying ghc api. Values are: -- -- * @606@ for GHC 6.6.x -- -- * @608@ for GHC 6.8.x -- -- * @610@ for GHC 6.10.x -- -- * etc... ghcVersion :: Int ghcVersion = __GLASGOW_HASKELL__ -- this requires FlexibleContexts class (MonadCatchIO m,MonadError InterpreterError 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) instance Error InterpreterError where noMsg = UnknownError "" strMsg = UnknownError data InterpreterState = St{active_phantoms :: [PhantomModule], zombie_phantoms :: [PhantomModule], hint_support_module :: PhantomModule, import_qual_hack_mod :: Maybe PhantomModule, qual_imports :: [(ModuleName, String)], defaultExts :: [(Extension,Bool)], -- R/O configuration :: InterpreterConfiguration} data InterpreterConfiguration = Conf { search_path :: [FilePath], language_exts :: [Extension], all_mods_in_scope :: Bool } #if __GLASGOW_HASKELL__ < 610 type InterpreterSession = SessionData GHC.Session adjust :: (a -> b -> c) -> (b -> a -> c) adjust f = flip f type RunGhc m a = (GHC.Session -> IO a) -> m a type RunGhc1 m a b = (GHC.Session -> a -> IO b) -> (a -> m b) type RunGhc2 m a b c = (GHC.Session -> a -> b -> IO c) -> (a -> b -> m c) type RunGhc3 m a b c d = (GHC.Session -> a -> b -> c -> IO d) -> (a -> b -> c -> m d) type RunGhc4 m a b c d e = (GHC.Session -> a -> b -> c -> d -> IO e) -> (a -> b -> c -> d -> m e) type RunGhc5 m a b c d e f = (GHC.Session -> a -> b -> c -> d -> e -> IO f) -> (a -> b -> c -> d -> e -> m f) #else -- ghc >= 6.10 type InterpreterSession = SessionData () instance Exception InterpreterError adjust :: (a -> b) -> (a -> b) adjust = id type RunGhc m a = (forall n.(MonadCatchIO n,Functor n) => GHC.GhcT n a) -> m a type RunGhc1 m a b = (forall n.(MonadCatchIO n, Functor n) => a -> GHC.GhcT n b) -> (a -> m b) type RunGhc2 m a b c = (forall n.(MonadCatchIO n, Functor n) => a -> b -> GHC.GhcT n c) -> (a -> b -> m c) type RunGhc3 m a b c d = (forall n.(MonadCatchIO n, Functor n) => a -> b -> c -> GHC.GhcT n d) -> (a -> b -> c -> m d) type RunGhc4 m a b c d e = (forall n.(MonadCatchIO n, Functor n) => a -> b -> c -> d -> GHC.GhcT n e) -> (a -> b -> c -> d -> m e) type RunGhc5 m a b c d e f = (forall n.(MonadCatchIO n, Functor n) => a->b->c->d->e->GHC.GhcT n f) -> (a -> b -> c -> d -> e -> m f) #endif 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 = do action `catchError` (\err -> case err of GhcException s -> throwError (buildEx s) _ -> throwError err) #if __GLASGOW_HASKELL__ < 704 type GhcErrLogger = GHC.Severity -> GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> IO () #else type GhcErrLogger = GHC.LogAction #endif -- | Module names are _not_ filepaths. type ModuleName = String runGhc1 :: MonadInterpreter m => RunGhc1 m a b runGhc1 f a = runGhc (adjust f a) runGhc2 :: MonadInterpreter m => RunGhc2 m a b c runGhc2 f a = runGhc1 (adjust f a) runGhc3 :: MonadInterpreter m => RunGhc3 m a b c d runGhc3 f a = runGhc2 (adjust f a) runGhc4 :: MonadInterpreter m => RunGhc4 m a b c d e runGhc4 f a = runGhc3 (adjust f a) runGhc5 :: MonadInterpreter m => RunGhc5 m a b c d e f runGhc5 f a = runGhc4 (adjust 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) -> throwError $ UnknownError "Got no error message" (Nothing,False) -> throwError $ WontCompile (reverse es) (Just a, True) -> return a (Just _, False) -> fail $ "GHC returned a result but said: " ++ show es -- ================ Misc =================================== -- this type ought to go in Hint.Context, but ghc dislikes cyclic imports... data PhantomModule = PhantomModule{pm_name :: ModuleName, pm_file :: 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) `catchError` (\e -> case e of NotAllowed{} -> return False _ -> throwError e) hint-0.3.3.6/src/Hint/Compat.hs0000644000000000000000000001771012117644541014274 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Hint.Compat where #if __GLASGOW_HASKELL__ < 702 import Control.Monad.Trans (liftIO) #endif #if __GLASGOW_HASKELL__ >= 704 import Control.Monad (foldM, liftM) #endif import qualified Hint.GHC as GHC -- Kinds became a synonym for Type in GHC 6.8. We define this wrapper -- to be able to define a FromGhcRep instance for both versions newtype Kind = Kind GHC.Kind #if __GLASGOW_HASKELL__ >= 700 -- supportedLanguages :: [String] supportedExtensions = map f GHC.xFlags where #if (__GLASGOW_HASKELL__ < 702) || (__GLASGOW_HASKELL__ >= 704) f (e,_,_) = e #else f (e,_,_,_) = e #endif #if __GLASGOW_HASKELL__ < 702 -- setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContext xs = GHC.setContext xs . map (\y -> (y,Nothing)) getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.Module]) getContext = fmap (\(as,bs) -> (as,map fst bs)) GHC.getContext #elif __GLASGOW_HASKELL__ < 704 -- Keep setContext/getContext unmodified for use where the results of getContext -- are simply restored by setContext, in which case we don't really care about the -- particular type of b. -- setContext :: GHC.GhcMonad m => [GHC.Module] -> [b] -> m () setContext = GHC.setContext -- getContext :: GHC.GhcMonad m => m ([GHC.Module], [b]) getContext = GHC.getContext #else setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.ImportDecl GHC.RdrName] -> m () setContext ms ds = let ms' = map modToIIMod ms ds' = map GHC.IIDecl ds is = ms' ++ ds' in GHC.setContext is getContext :: GHC.GhcMonad m => m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) getContext = GHC.getContext >>= foldM f ([], []) where f :: (GHC.GhcMonad m) => ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) -> GHC.InteractiveImport -> m ([GHC.Module], [GHC.ImportDecl GHC.RdrName]) 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 iiModToMod :: GHC.GhcMonad m => GHC.InteractiveImport -> m GHC.Module #if __GLASGOW_HASKELL__ < 706 modToIIMod = GHC.IIModule iiModToMod (GHC.IIModule m) = return m #else modToIIMod = GHC.IIModule . GHC.moduleName iiModToMod (GHC.IIModule m) = GHC.findModule m Nothing #endif iiModToMod _ = error "iiModToMod!" #endif mkPState = GHC.mkPState #else -- supportedExtensions :: [String] supportedExtensions = GHC.supportedLanguages -- setContext :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () -- i don't want to check the signature on every ghc version.... setContext = GHC.setContext getContext = GHC.getContext mkPState df buf loc = GHC.mkPState buf loc df #endif -- Explicitly-typed variants of getContext/setContext, for use where we modify -- or override the context. #if __GLASGOW_HASKELL__ < 702 setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContextModules = setContext getContextNames :: GHC.GhcMonad m => m([String], [String]) getContextNames = fmap (\(as,bs) -> (map name as, map name bs)) getContext where name = GHC.moduleNameString . GHC.moduleName #else setContextModules :: GHC.GhcMonad m => [GHC.Module] -> [GHC.Module] -> m () setContextModules as = setContext as . map (GHC.simpleImportDecl . GHC.moduleName) getContextNames :: GHC.GhcMonad m => m([String], [String]) getContextNames = fmap (\(as,bs) -> (map name as, map decl bs)) getContext where name = GHC.moduleNameString . GHC.moduleName decl = GHC.moduleNameString . GHC.unLoc . GHC.ideclName #endif #if __GLASGOW_HASKELL__ < 702 mkSrcLoc = GHC.mkSrcLoc stringToStringBuffer = liftIO . GHC.stringToStringBuffer #else mkSrcLoc = GHC.mkRealSrcLoc stringToStringBuffer = return . GHC.stringToStringBuffer #endif #if __GLASGOW_HASKELL__ >= 610 configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags = 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) fileTarget :: FilePath -> GHC.Target fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) True Nothing where next_phase = GHC.Cpp GHC.HsSrcFile targetId :: GHC.Target -> GHC.TargetId targetId = GHC.targetId guessTarget :: GHC.GhcMonad m => String -> Maybe GHC.Phase -> m GHC.Target guessTarget = GHC.guessTarget -- 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 -- add a bogus Maybe, in order to use it with mayFail exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type) exprType = fmap Just . GHC.exprType -- add a bogus Maybe, in order to use it with mayFail #if __GLASGOW_HASKELL__ < 704 typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) typeKind = fmap Just . GHC.typeKind #else typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) typeKind = fmap Just . (liftM snd) . (GHC.typeKind True) #endif #else -- add a bogus session parameter, in order to use it with runGhc2 parseDynamicFlags :: GHC.Session -> GHC.DynFlags -> [String] -> IO (GHC.DynFlags, [String]) parseDynamicFlags = const GHC.parseDynamicFlags fileTarget :: FilePath -> GHC.Target fileTarget f = GHC.Target (GHC.TargetFile f $ Just next_phase) Nothing where next_phase = GHC.Cpp GHC.HsSrcFile targetId :: GHC.Target -> GHC.TargetId targetId (GHC.Target _id _) = _id -- add a bogus session parameter, in order to use it with runGhc2 guessTarget :: GHC.Session -> String -> Maybe GHC.Phase -> IO GHC.Target guessTarget = const GHC.guessTarget compileExpr :: GHC.Session -> String -> IO (Maybe GHC.HValue) compileExpr = GHC.compileExpr exprType :: GHC.Session -> String -> IO (Maybe GHC.Type) exprType = GHC.exprType typeKind :: GHC.Session -> String -> IO (Maybe GHC.Kind) typeKind = GHC.typeKind #endif #if __GLASGOW_HASKELL__ >= 608 #if __GLASGOW_HASKELL__ < 610 -- 6.08 only newSession :: FilePath -> IO GHC.Session newSession ghc_root = GHC.newSession (Just ghc_root) configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager, GHC.hscTarget = GHC.HscInterpreted, GHC.ghcLink = GHC.LinkInMemory} #endif #if __GLASGOW_HASKELL__ < 701 -- 6.08 - 7.0.4 pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc) pprType = GHC.pprTypeForUser False -- False means drop explicit foralls pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc) pprKind = pprType #else -- 7.2.1 and above pprType :: GHC.Type -> GHC.SDoc pprType = GHC.pprTypeForUser False -- False means drop explicit foralls pprKind :: GHC.Kind -> GHC.SDoc pprKind = pprType #endif #elif __GLASGOW_HASKELL__ >= 606 -- 6.6 only newSession :: FilePath -> IO GHC.Session newSession ghc_root = GHC.newSession GHC.Interactive (Just ghc_root) configureDynFlags :: GHC.DynFlags -> GHC.DynFlags configureDynFlags dflags = dflags{GHC.hscTarget = GHC.HscInterpreted} pprType :: GHC.Type -> (GHC.PprStyle -> GHC.Doc) pprType = GHC.ppr . GHC.dropForAlls pprKind :: GHC.Kind -> (GHC.PprStyle -> GHC.Doc) pprKind = GHC.ppr #endif #if __GLASGOW_HASKELL__ >= 706 -- why did they have to add a DynFlag to each showSDocXXX function.... (sigh) showSDoc = GHC.showSDoc GHC.tracingDynFlags -- hack! showSDocForUser = GHC.showSDocForUser GHC.tracingDynFlags -- hack! showSDocUnqual = GHC.showSDocUnqual #else showSDoc = GHC.showSDoc showSDocForUser = GHC.showSDocForUser showSDocUnqual = const GHC.showSDocUnqual #endif #if __GLASGOW_HASKELL__ >= 706 mkLocMessage = GHC.mkLocMessage GHC.SevError #else mkLocMessage = GHC.mkLocMessage #endif hint-0.3.3.6/src/Hint/Configuration.hs0000644000000000000000000001665712117644541015671 0ustar0000000000000000module Hint.Configuration ( setGhcOption, setGhcOptions, defaultConf, fromConf, onConf, get, set, Option, OptionVal(..), languageExtensions, availableExtensions, glasgowExtensions, Extension(..), installedModulesInScope, setUseLanguageExtensions, setInstalledModsAreInScopeQualified, searchPath ) where import Control.Monad.Error import Data.Char import Data.List ( intersect, intercalate ) import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat 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 Compat.parseDynamicFlags old_flags opts when (not . null $ not_parsed) $ throwError $ 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 { language_exts = [], all_mods_in_scope = False, search_path = ["."] } -- | 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{language_exts = es} -- getter = fromConf language_exts -- 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 -- | List of extensions turned on when the @-fglasgow-exts@ flag is used {-# DEPRECATED glasgowExtensions "glasgowExtensions list is no longer maintained, will be removed soon" #-} glasgowExtensions :: [Extension] glasgowExtensions = intersect availableExtensions exts612 -- works also for 608 and 610 where exts612 = map asExtension ["PrintExplicitForalls", "ForeignFunctionInterface", "UnliftedFFITypes", "GADTs", "ImplicitParams", "ScopedTypeVariables", "UnboxedTuples", "TypeSynonymInstances", "StandaloneDeriving", "DeriveDataTypeable", "FlexibleContexts", "FlexibleInstances", "ConstrainedClassMethods", "MultiParamTypeClasses", "FunctionalDependencies", "MagicHash", "PolymorphicComponents", "ExistentialQuantification", "UnicodeSyntax", "PostfixOperators", "PatternGuards", "LiberalTypeSynonyms", "ExplicitForAll", "RankNTypes", "ImpredicativeTypes", "TypeOperators", "RecursiveDo", "DoRec", "ParallelListComp", "EmptyDataDecls", "KindSignatures", "GeneralizedNewtypeDeriving", "TypeFamilies" ] -- | 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 all_mods_in_scope setter b = do onConf $ \c -> c{all_mods_in_scope = b} when ( ghcVersion >= 610 ) $ 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 search_path setter p = do onConf $ \c -> c{search_path = p} setGhcOption $ "-i" -- clear the old path setGhcOption $ "-i" ++ intercalate ":" p 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)} {-# DEPRECATED setUseLanguageExtensions "Use set [languageExtensions := (ExtendedDefaultRules:glasgowExtensions)] instead." #-} setUseLanguageExtensions :: MonadInterpreter m => Bool -> m () setUseLanguageExtensions False = set [languageExtensions := []] setUseLanguageExtensions True = set [languageExtensions := exts] where exts = ExtendedDefaultRules : glasgowExtensions {-# DEPRECATED setInstalledModsAreInScopeQualified "Use set [installedModulesInScope := b] instead." #-} setInstalledModsAreInScopeQualified :: MonadInterpreter m => Bool -> m () setInstalledModsAreInScopeQualified b = set [installedModulesInScope := b] hint-0.3.3.6/src/Hint/Context.hs0000644000000000000000000003401512117644541014472 0ustar0000000000000000module Hint.Context ( ModuleName, isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, PhantomModule(..), ModuleText, addPhantomModule, removePhantomModule, getPhantomModules, cleanPhantomModules, allModulesInContext, onAnEmptyContext, support_String, support_show ) where import Prelude hiding ( mod ) import Data.Char import Data.List import Control.Monad ( liftM, filterM, when, guard ) import Control.Monad.Error ( catchError, throwError, liftIO ) import Hint.Base import Hint.Util ( (>=>) ) -- compat version import Hint.Conversions import qualified Hint.Util as Util import qualified Hint.Compat as Compat import qualified Hint.GHC as GHC import System.Random import System.FilePath import System.Directory import qualified System.IO.UTF8 as UTF8 (writeFile) 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 newPhantomModule :: MonadInterpreter m => m PhantomModule newPhantomModule = do n <- liftIO randomIO (ls,is) <- allModulesInContext let nums = concat [show (abs n::Int), filter isDigit $ concat (ls ++ is)] let mod_name = 'M':nums -- tmp_dir <- liftIO getTemporaryDirectory -- return PhantomModule{pm_name = mod_name, pm_file = tmp_dir nums} allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext = runGhc Compat.getContextNames addPhantomModule :: MonadInterpreter m => (ModuleName -> ModuleText) -> m PhantomModule addPhantomModule mod_text = do pm <- newPhantomModule let t = Compat.fileTarget (pm_file pm) m = GHC.mkModuleName (pm_name pm) -- liftIO $ UTF8.writeFile (pm_file pm) (mod_text $ pm_name pm) -- onState (\s -> s{active_phantoms = pm:active_phantoms s}) mayFail (do -- GHC.load will remove all the modules from scope, so first -- we save the context... (old_top, old_imps) <- runGhc Compat.getContext -- runGhc1 GHC.addTarget t res <- runGhc1 GHC.load (GHC.LoadUpTo m) -- if isSucceeded res then do runGhc2 Compat.setContext old_top old_imps return $ Just () else return Nothing) `catchError` (\err -> case err of WontCompile _ -> do removePhantomModule pm throwError err _ -> throwError 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 $ pm_name pm safeToRemove <- if isLoaded then do -- take it out of scope mod <- findModule (pm_name pm) (mods, imps) <- runGhc Compat.getContext let mods' = filter (mod /=) mods runGhc2 Compat.setContext mods' imps -- let isNotPhantom = isPhantomModule . fromGhcRep_ >=> return . not null `liftM` filterM isNotPhantom mods' else return True -- let file_name = pm_file pm runGhc1 GHC.removeTarget (Compat.targetId $ Compat.fileTarget file_name) -- onState (\s -> s{active_phantoms = filter (pm /=) $ active_phantoms s}) -- if safeToRemove then do mayFail $ do res <- runGhc1 GHC.load GHC.LoadAllTargets return $ guard (isSucceeded res) >> Just () liftIO $ removeFile (pm_file pm) else do onState (\s -> s{zombie_phantoms = pm:zombie_phantoms s}) return () -- Returns a tuple with the active and zombie phantom modules respectively getPhantomModules :: MonadInterpreter m => m ([PhantomModule], [PhantomModule]) getPhantomModules = do active <- fromState active_phantoms zombie <- fromState zombie_phantoms return (active, zombie) isPhantomModule :: MonadInterpreter m => ModuleName -> m Bool isPhantomModule mn = do (as,zs) <- getPhantomModules return $ mn `elem` (map pm_name $ 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. loadModules :: MonadInterpreter m => [String] -> m () loadModules fs = do -- first, unload everything, and do some clean-up reset doLoad fs `catchError` (\e -> reset >> throwError e) doLoad :: MonadInterpreter m => [String] -> m () doLoad fs = do mayFail $ do targets <- mapM (\f->runGhc2 Compat.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 pm_name $ active_pms ++ zombie_pms) modNameFromSummary :: GHC.ModSummary -> ModuleName modNameFromSummary = fromGhcRep_ . 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) 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 when (not . null $ not_loaded) $ throwError $ NotAllowed ("These modules have not been loaded:\n" ++ unlines not_loaded) -- active_pms <- fromState active_phantoms ms_mods <- mapM findModule (nub $ ms ++ map pm_name active_pms) -- let mod_is_interpr = runGhc1 GHC.moduleIsInterpreted not_interpreted <- filterM (liftM not . mod_is_interpr) ms_mods when (not . null $ not_interpreted) $ throwError $ NotAllowed ("These modules are not interpreted:\n" ++ unlines (map fromGhcRep_ not_interpreted)) -- (_, old_imports) <- runGhc Compat.getContext runGhc2 Compat.setContext ms_mods old_imports onAnEmptyContext :: MonadInterpreter m => m a -> m a onAnEmptyContext action = do (old_mods, old_imps) <- runGhc Compat.getContext runGhc2 Compat.setContext [] [] let restore = runGhc2 Compat.setContext old_mods old_imps a <- action `catchError` (\e -> do restore; throwError e) restore return a -- | Sets the modules whose exports must be in context. -- -- Warning: 'setImports' and 'setImportsQ' are mutually exclusive. -- If you have a list of modules to be used qualified and another list -- unqualified, then you need to do something like -- -- > setImportsQ ((zip unqualified $ repeat Nothing) ++ qualifieds) setImports :: MonadInterpreter m => [ModuleName] -> m () setImports ms = setImportsQ $ zip ms (repeat Nothing) -- | Sets the modules whose exports must be in context; some -- of them may be qualified. E.g.: -- -- @setImports [("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 = do let qualOrNot = \(a,mb) -> maybe (Right a) (Left . (,) a) mb (quals,unquals) = Util.partitionEither $ map qualOrNot ms -- unqual_mods <- mapM findModule unquals mapM_ (findModule . fst) quals -- just to be sure they exist -- old_qual_hack_mod <- fromState import_qual_hack_mod maybe (return ()) removePhantomModule old_qual_hack_mod -- new_pm <- if ( not $ null quals ) then do new_pm <- addPhantomModule $ \mod_name -> unlines $ ("module " ++ mod_name ++ " where ") : ["import qualified " ++ m ++ " as " ++ n | (m,n) <- quals] onState (\s -> s{import_qual_hack_mod = Just new_pm}) return $ Just new_pm else return Nothing -- pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm (old_top_level, _) <- runGhc Compat.getContext let new_top_level = pm ++ old_top_level runGhc2 Compat.setContextModules new_top_level unqual_mods -- onState (\s ->s{qual_imports = quals}) -- | '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 Compat.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 active_phantoms old_zombie <- fromState zombie_phantoms onState (\s -> s{active_phantoms = [], zombie_phantoms = [], import_qual_hack_mod = Nothing, qual_imports = []}) liftIO $ mapM_ (removeFile . pm_file) (old_active ++ old_zombie) -- | 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{hint_support_module = mod}) mod' <- findModule (pm_name mod) runGhc2 Compat.setContext [mod'] [] -- where support_module m = unlines [ "module " ++ m ++ "( ", " " ++ _String ++ ",", " " ++ _show ++ ")", "where", "", "import qualified Prelude as P", "", "type " ++ _String ++ " = P.String", "", _show ++ " :: P.Show a => a -> P.String", _show ++ " = P.show" ] where _String = altStringName m _show = altShowName 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 hint_support_module removePhantomModule pm installSupportModule altStringName :: ModuleName -> String altStringName mod_name = "String_" ++ mod_name altShowName :: ModuleName -> String altShowName mod_name = "show_" ++ mod_name support_String :: MonadInterpreter m => m String support_String = do mod_name <- fromState (pm_name . hint_support_module) return $ concat [mod_name, ".", altStringName mod_name] support_show :: MonadInterpreter m => m String support_show = do mod_name <- fromState (pm_name . hint_support_module) return $ concat [mod_name, ".", altShowName mod_name] -- SHOULD WE CALL THIS WHEN MODULES ARE LOADED / UNLOADED? -- foreign import ccall "revertCAFs" rts_revertCAFs :: IO () hint-0.3.3.6/src/Hint/Conversions.hs0000644000000000000000000000371112117644541015355 0ustar0000000000000000module Hint.Conversions( FromGhcRep(..), FromGhcRep_(..), isSucceeded ) where import qualified Hint.GHC as GHC import Hint.Base import qualified Hint.Compat as Compat import Language.Haskell.Syntax ( HsModule(..), HsDecl(..), HsQualType ) import Language.Haskell.Parser ( parseModule, ParseResult(ParseOk) ) -- | Conversions from GHC representation to standard representations class FromGhcRep ghc target where fromGhcRep :: MonadInterpreter m => ghc -> m target class FromGhcRep_ ghc target where fromGhcRep_ :: ghc -> target -- --------- Types / Kinds ----------------------- instance FromGhcRep GHC.Type HsQualType where fromGhcRep t = do t_str <- fromGhcRep t -- let mod_str = unlines ["f ::" ++ t_str, "f = undefined"] let HsModule _ _ _ _ [decl,_] = parseModule' mod_str HsTypeSig _ _ qualType = decl -- return qualType instance FromGhcRep GHC.Type String where fromGhcRep t = do -- Unqualify necessary types -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual return $ Compat.showSDocForUser unqual (Compat.pprType t) parseModule' :: String -> HsModule parseModule' s = case parseModule s of ParseOk m -> m failed -> error $ unlines ["parseModulde' failed?!", s, show failed] instance FromGhcRep_ Compat.Kind String where fromGhcRep_ (Compat.Kind k) = Compat.showSDoc (Compat.pprKind k) -- ---------------- Modules -------------------------- instance FromGhcRep_ GHC.Module String where fromGhcRep_ = GHC.moduleNameString . GHC.moduleName -- ---------------- Misc ----------------------------- isSucceeded :: GHC.SuccessFlag -> Bool isSucceeded GHC.Succeeded = True isSucceeded GHC.Failed = False hint-0.3.3.6/src/Hint/Eval.hs0000644000000000000000000000476612117644541013747 0ustar0000000000000000module Hint.Eval ( interpret, as, infer, eval ,parens) where import qualified GHC.Exts ( unsafeCoerce# ) import Data.Typeable hiding ( typeOf ) import qualified Data.Typeable ( typeOf ) import Hint.Base import Hint.Context import Hint.Parsers import Hint.Sandbox import Hint.Util import qualified Hint.Compat as Compat -- | Convenience functions to be used with @interpret@ to provide witnesses. -- Example: -- -- * @interpret \"head [True,False]\" (as :: Bool)@ -- -- * @interpret \"head $ map show [True,False]\" infer >>= flip interpret (as :: Bool)@ as, infer :: Typeable a => a as = undefined infer = undefined -- | Evaluates an expression, given a witness for its monomorphic type. interpret :: (MonadInterpreter m, Typeable a) => String -> a -> m a interpret expr wit = unsafeInterpret expr (show $ Data.Typeable.typeOf wit) unsafeInterpret :: (MonadInterpreter m) => String -> String -> m a unsafeInterpret expr type_str = sandboxed go expr where go e = 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 e -- let expr_typesig = concat [parens e, " :: ", type_str] expr_val <- mayFail $ runGhc1 Compat.compileExpr expr_typesig -- return (GHC.Exts.unsafeCoerce# expr_val :: a) -- | @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 <- support_show in_scope_String <- support_String let show_expr = unwords [in_scope_show, parens expr] unsafeInterpret show_expr in_scope_String -- | 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 hint-0.3.3.6/src/Hint/Extension.hs0000644000000000000000000001362112117644541015022 0ustar0000000000000000-- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead module Hint.Extension (Extension(..), knownExtensions, availableExtensions, asExtension) where import Hint.Compat as Compat -- | List of the extensions known by the interpreter. availableExtensions :: [Extension] availableExtensions = map asExtension Compat.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 | NoMonomorphismRestriction | FunctionalDependencies | Rank2Types | RankNTypes | PolymorphicComponents | ExistentialQuantification | ScopedTypeVariables | ImplicitParams | FlexibleContexts | FlexibleInstances | EmptyDataDecls | CPP | KindSignatures | BangPatterns | TypeSynonymInstances | TemplateHaskell | ForeignFunctionInterface | Arrows | Generics | NoImplicitPrelude | NamedFieldPuns | PatternGuards | GeneralizedNewtypeDeriving | ExtensibleRecords | RestrictedTypeSynonyms | HereDocuments | MagicHash | TypeFamilies | StandaloneDeriving | UnicodeSyntax | PatternSignatures | UnliftedFFITypes | LiberalTypeSynonyms | TypeOperators | RecordWildCards | RecordPuns | DisambiguateRecordFields | OverloadedStrings | GADTs | NoMonoPatBinds | RelaxedPolyRec | ExtendedDefaultRules | UnboxedTuples | DeriveDataTypeable | ConstrainedClassMethods | PackageImports | ImpredicativeTypes | NewQualifiedOperators | PostfixOperators | QuasiQuotes | TransformListComp | ViewPatterns | XmlSyntax | RegularPatterns | TupleSections | GHCForeignImportPrim | NPlusKPatterns | DoAndIfThenElse | RebindableSyntax | ExplicitForAll | DatatypeContexts | MonoLocalBinds | DeriveFunctor | DeriveTraversable | DeriveFoldable | UnknownExtension String deriving (Eq, Show, Read) knownExtensions :: [Extension] knownExtensions = [OverlappingInstances, UndecidableInstances, IncoherentInstances, DoRec, RecursiveDo, ParallelListComp, MultiParamTypeClasses, NoMonomorphismRestriction, FunctionalDependencies, Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables, ImplicitParams, FlexibleContexts, FlexibleInstances, EmptyDataDecls, CPP, KindSignatures, BangPatterns, TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface, Arrows, Generics, NoImplicitPrelude, NamedFieldPuns, PatternGuards, GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms, HereDocuments, MagicHash, TypeFamilies, StandaloneDeriving, UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms, TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields, OverloadedStrings, GADTs, NoMonoPatBinds, RelaxedPolyRec, ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable, ConstrainedClassMethods, PackageImports, ImpredicativeTypes, NewQualifiedOperators, PostfixOperators, QuasiQuotes, TransformListComp, ViewPatterns, XmlSyntax, RegularPatterns, TupleSections, GHCForeignImportPrim, NPlusKPatterns, DoAndIfThenElse, RebindableSyntax, ExplicitForAll, DatatypeContexts, MonoLocalBinds, DeriveFunctor, DeriveTraversable, DeriveFoldable ] hint-0.3.3.6/src/Hint/GHC.hs0000644000000000000000000000364712117644541013456 0ustar0000000000000000module Hint.GHC ( module GHC, module Outputable, module ErrUtils, Message, module Pretty, module DriverPhases, module StringBuffer, module Lexer, module Parser, module DynFlags, module FastString, #if __GLASGOW_HASKELL__ >= 610 module Control.Monad.Ghc, module HscTypes, module Bag, #endif #if __GLASGOW_HASKELL__ >= 608 module PprTyThing, #elif __GLASGOW_HASKELL__ < 608 module SrcLoc, #endif #if __GLASGOW_HASKELL__ >= 702 module SrcLoc, #endif ) where #if __GLASGOW_HASKELL__ >= 610 import GHC hiding ( Phase, GhcT, runGhcT ) import Control.Monad.Ghc ( GhcT, runGhcT ) import HscTypes ( SourceError, srcErrorMessages, GhcApiError ) import Bag ( bagToList ) #else import GHC hiding ( Phase ) #endif import Outputable ( PprStyle, SDoc, ppr, showSDoc, showSDocForUser, showSDocUnqual, withPprStyle, defaultErrStyle ) import ErrUtils ( mkLocMessage ) #if __GLASGOW_HASKELL__ < 706 import ErrUtils ( Message ) #else import ErrUtils ( MsgDoc ) -- we alias it as Message below #endif import Pretty ( Doc ) import DriverPhases ( Phase(Cpp), HscSource(HsSrcFile) ) import StringBuffer ( stringToStringBuffer ) import Lexer ( P(..), ParseResult(..), mkPState ) import Parser ( parseStmt, parseType ) import FastString ( fsLit ) #if __GLASGOW_HASKELL__ >= 700 import DynFlags ( supportedLanguagesAndExtensions, xFlags, xopt ) #else import DynFlags ( supportedLanguages ) #endif #if __GLASGOW_HASKELL__ >=704 import DynFlags ( LogAction ) #endif #if __GLASGOW_HASKELL__ >= 706 import DynFlags ( tracingDynFlags ) #endif #if __GLASGOW_HASKELL__ >= 608 import PprTyThing ( pprTypeForUser ) #elif __GLASGOW_HASKELL__ < 608 import SrcLoc ( SrcSpan ) #endif #if __GLASGOW_HASKELL__ >= 702 import SrcLoc ( mkRealSrcLoc ) #endif #if __GLASGOW_HASKELL__ >= 706 type Message = MsgDoc #endif hint-0.3.3.6/src/Hint/InterpreterT.hs0000644000000000000000000002244712117644541015503 0ustar0000000000000000module Hint.InterpreterT ( InterpreterT, Interpreter, runInterpreter, runInterpreterWithArgs, MultipleInstancesNotAllowed(..) ) where import Prelude hiding ( catch ) import Hint.Base import Hint.Context import Hint.Configuration import Hint.Extension import Control.Applicative import Control.Monad.Reader import Control.Monad.Error import Control.Monad.CatchIO import Data.Typeable ( Typeable ) import Control.Concurrent.MVar import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef import Data.List import Data.Maybe #if __GLASGOW_HASKELL__ < 610 import Data.Dynamic #endif import qualified GHC.Paths import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat type Interpreter = InterpreterT IO #if __GLASGOW_HASKELL__ < 610 newtype InterpreterT m a = InterpreterT{ unInterpreterT :: ReaderT InterpreterSession (ErrorT InterpreterError m) a} deriving (Functor, Monad, MonadIO, MonadCatchIO) execute :: (MonadCatchIO m, Functor m) => InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a) execute s = runErrorT . flip runReaderT s . unInterpreterT instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift runGhc_impl :: (MonadCatchIO m, Functor m) => RunGhc (InterpreterT m) a runGhc_impl f = do s <- fromSession versionSpecific -- i.e. the ghc session r <- liftIO $ f' s either throwError return r where f' = tryJust (fmap (GhcException . showGhcEx) . ghcExceptions) . f ghcExceptions (DynException e) = fromDynamic e ghcExceptions _ = Nothing #else -- ghc >= 6.10 newtype InterpreterT m a = InterpreterT{ unInterpreterT :: ReaderT InterpreterSession (ErrorT InterpreterError (GHC.GhcT m)) a} deriving (Functor, Monad, MonadIO, MonadCatchIO) execute :: (MonadCatchIO m, Functor m) => InterpreterSession -> InterpreterT m a -> m (Either InterpreterError a) execute s = GHC.runGhcT (Just GHC.Paths.libdir) . runErrorT . flip runReaderT s . unInterpreterT instance MonadTrans InterpreterT where lift = InterpreterT . lift . lift . lift runGhc_impl :: (MonadCatchIO m, Functor m) => RunGhc (InterpreterT m) a runGhc_impl a = InterpreterT (lift (lift a)) `catches` [Handler (\(e :: GHC.SourceError) -> rethrowWC e), Handler (\(e :: GHC.GhcApiError) -> rethrowGE $ show e), Handler (\(e :: GHC.GhcException) -> rethrowGE $ showGhcEx e)] where rethrowGE = throwError . GhcException rethrowWC = throwError . WontCompile . map (GhcError . show) . GHC.bagToList . GHC.srcErrorMessages #endif showGhcEx :: GHC.GhcException -> String showGhcEx = flip GHC.showGhcException "" -- ================= Executing the interpreter ================== initialize :: (MonadCatchIO 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 = Compat.configureDynFlags df0 (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args when (not . null $ extra) $ throwError $ UnknownError (concat [ "flags: '" , intercalate " " 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} #if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 704 let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags #else let extMap = map (\(a,_,b,_) -> (a,b)) GHC.xFlags #endif #else let extMap = map (\(a,b,_) -> (a,b)) GHC.xFlags #endif let toOpt e = let err = error ("init error: unknown ext:" ++ show e) in fromMaybe err (lookup e extMap) let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2) let defExts = map getOptVal Compat.supportedExtensions #else let defExts = zip availableExtensions (repeat False) #endif onState (\s -> s{defaultExts = defExts}) reset -- | Executes the interpreter. Returns @Left InterpreterError@ in case of error. -- -- NB. The underlying ghc will overwrite certain signal handlers -- (SIGINT, SIGHUP, SIGTERM, SIGQUIT on Posix systems, Ctrl-C handler on Windows). -- In future versions of hint, this might be controlled by the user. runInterpreter :: (MonadCatchIO m, Functor 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 :: (MonadCatchIO m, Functor m) => [String] -> InterpreterT m a -> m (Either InterpreterError a) runInterpreterWithArgs args action = ifInterpreterNotRunning $ do s <- newInterpreterSession `catch` rethrowGhcException -- SH.protectHandlers $ execute s (initialize args >> action) execute s (initialize args >> action `finally` cleanSession) where rethrowGhcException = throw . GhcException . showGhcEx #if __GLASGOW_HASKELL__ < 610 newInterpreterSession = do s <- liftIO $ Compat.newSession GHC.Paths.libdir newSessionData s cleanSession = cleanPhantomModules -- clean ghc session, too? #else -- GHC >= 610 newInterpreterSession = newSessionData () cleanSession = do cleanPhantomModules runGhc $ do dflags <- GHC.getSessionDynFlags GHC.defaultCleanupHandler dflags (return ()) #endif {-# NOINLINE uniqueToken #-} uniqueToken :: MVar () uniqueToken = unsafePerformIO $ newMVar () ifInterpreterNotRunning :: MonadCatchIO m => m a -> m a ifInterpreterNotRunning action = do maybe_token <- liftIO $ tryTakeMVar uniqueToken case maybe_token of Nothing -> throw 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 {active_phantoms = [], zombie_phantoms = [], hint_support_module = error "No support module loaded!", import_qual_hack_mod = Nothing, qual_imports = [], 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 = compat $ \_ src style msg -> let errorEntry = mkGhcError src style msg in modifyIORef r (errorEntry :) where #if __GLASGOW_HASKELL__ < 706 compat = id #else compat = const -- cater for the extra DynFlags args #endif mkGhcError :: GHC.SrcSpan -> GHC.PprStyle -> GHC.Message -> GhcError mkGhcError src_span style msg = GhcError{errMsg = niceErrMsg} where niceErrMsg = Compat.showSDoc . GHC.withPprStyle style $ Compat.mkLocMessage src_span msg -- The MonadInterpreter instance instance (MonadCatchIO m, Functor m) => MonadInterpreter (InterpreterT m) where fromSession f = InterpreterT $ fmap f ask -- modifySessionRef target f = do ref <- fromSession target old_val <- liftIO $ atomicModifyIORef ref (\a -> (f a, a)) return old_val -- runGhc a = runGhc_impl a instance Monad m => MonadError InterpreterError (InterpreterT m) where throwError = InterpreterT . throwError catchError (InterpreterT m) catchE = InterpreterT $ m `catchError` (\e -> unInterpreterT $ catchE e) instance (Monad m, Applicative m) => Applicative (InterpreterT m) where pure = return (<*>) = ap hint-0.3.3.6/src/Hint/Parsers.hs0000644000000000000000000000466512117644541014475 0ustar0000000000000000module Hint.Parsers where import Prelude hiding(span) import Hint.Base import qualified Hint.Compat as Compat 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 <- Compat.stringToStringBuffer expr -- -- ghc >= 7 panics if noSrcLoc is given let srcLoc = Compat.mkSrcLoc (GHC.fsLit "") 1 1 let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk -- GHC.PFailed span err -> 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 #if __GLASGOW_HASKELL__ >= 706 dflags <- runGhc GHC.getSessionDynFlags let logger' = logger dflags errStyle = GHC.defaultErrStyle dflags #else let logger' = logger errStyle = GHC.defaultErrStyle #endif liftIO $ logger' GHC.SevError span errStyle err -- -- behave like the rest of the GHC API functions -- do on error... return Nothing hint-0.3.3.6/src/Hint/Reflection.hs0000644000000000000000000000577612117644541015154 0ustar0000000000000000module Hint.Reflection ( ModuleElem(..), Id, name, children, getModuleExports, ) where import Data.List import Data.Maybe import Hint.Base import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat -- | 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) = ( #if __GLASGOW_HASKELL__ < 704 [asModElem df c | c@GHC.AClass{} <- xs], [asModElem df t | t@GHC.ATyCon{} <- xs], #else [asModElem df c | c@(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], [asModElem df t | t@(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], #endif [asModElem df d | d@GHC.ADataCon{} <- 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.ADataCon dc) = Fun $ getUnqualName df dc #if __GLASGOW_HASKELL__ < 704 asModElem df(GHC.ATyCon tc) = Data (getUnqualName df tc) (map (getUnqualName df) $ GHC.tyConDataCons tc) asModElem df (GHC.AClass c) = Class (getUnqualName df c) (map (getUnqualName df) $ GHC.classMethods c) #else 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!" #endif getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String getUnqualName dfs = Compat.showSDocUnqual dfs . GHC.pprParenSymName hint-0.3.3.6/src/Hint/Sandbox.hs0000644000000000000000000000714712117644541014452 0ustar0000000000000000module Hint.Sandbox ( sandboxed ) where import Hint.Base import Hint.Context import Hint.Configuration import Hint.Util import {-# SOURCE #-} Hint.Typecheck ( typeChecks_unsandboxed ) import Control.Monad.Error sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a) sandboxed = if ghcVersion >= 610 then id else old_sandboxed old_sandboxed :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a) old_sandboxed do_stuff = \expr -> do no_sandbox <- fromConf all_mods_in_scope if no_sandbox then do_stuff expr else usingAModule do_stuff expr usingAModule :: MonadInterpreter m => (Expr -> m a) -> (Expr -> m a) usingAModule do_stuff_on = \expr -> -- -- To avoid defaulting, we will evaluate this expression without the -- monomorphism-restriction. This means that expressions that normally -- would not typecheck, suddenly will. Thus, we first check if the -- expression typechecks as is. If it doesn't, there is no need in -- going on (if it does, it may not typecheck once we restrict the -- context; that is the whole idea of this!) -- do type_checks <- typeChecks_unsandboxed expr case type_checks of False -> do_stuff_on expr -- fail as you wish... True -> do (loaded, imports) <- allModulesInContext zombies <- fromState zombie_phantoms quals <- fromState qual_imports -- let e = safeBndFor expr let mod_text no_prel mod_name = textify [ ["{-# LANGUAGE NoMonomorphismRestriction #-}"], ["{-# LANGUAGE NoImplicitPrelude #-}" | no_prel], ["module " ++ mod_name], ["where"], ["import " ++ m | m <- loaded ++ imports, not $ m `elem` (map pm_name zombies)], ["import qualified " ++ m ++ " as " ++ q | (m,q) <- quals], [e ++ " = " ++ expr] ] -- let go no_prel = do pm <- addPhantomModule (mod_text no_prel) setTopLevelModules [pm_name pm] r <- do_stuff_on e `catchError` (\err -> case err of WontCompile _ -> do removePhantomModule pm throwError err _ -> throwError err) removePhantomModule pm return r -- If the Prelude was not explicitly imported but implicitly -- imported in some interpreted module, then the user may -- get very unintuitive errors when turning sandboxing on. Thus -- we will import the Prelude if the operation fails... -- I guess this may lead to even more obscure errors, but -- hopefully in much less frequent situations... r <- onAnEmptyContext $ go True `catchError` (\err -> case err of WontCompile _ -> go False _ -> throwError err) -- return r -- where textify = unlines . concat hint-0.3.3.6/src/Hint/SignalHandlers.hs0000644000000000000000000000202212117644541015735 0ustar0000000000000000module Hint.SignalHandlers ( protectHandlers ) where import Control.Monad.CatchIO import Control.Monad.Trans #ifdef mingw32_HOST_OS import GHC.ConsoleHandler as C saveHandlers :: MonadCatchIO m => m C.Handler saveHandlers = liftIO $ C.installHandler Ignore restoreHandlers :: MonadCatchIO m => C.Handler -> m C.Handler restoreHandlers = liftIO . C.installHandler #else import qualified System.Posix.Signals as S helper :: MonadCatchIO m => S.Handler -> S.Signal -> m S.Handler helper handler signal = liftIO $ S.installHandler signal handler Nothing signals :: [S.Signal] signals = [ S.sigQUIT , S.sigINT , S.sigHUP , S.sigTERM ] saveHandlers :: MonadCatchIO m => m [S.Handler] saveHandlers = liftIO $ mapM (helper S.Ignore) signals restoreHandlers :: MonadCatchIO m => [S.Handler] -> m [S.Handler] restoreHandlers h = liftIO . sequence $ zipWith helper h signals #endif protectHandlers :: MonadCatchIO m => m a -> m a protectHandlers a = bracket saveHandlers restoreHandlers $ const a hint-0.3.3.6/src/Hint/Typecheck.hs0000644000000000000000000000405112117644541014762 0ustar0000000000000000module Hint.Typecheck ( typeOf, typeChecks, kindOf, typeOf_unsandboxed, typeChecks_unsandboxed ) where import Control.Monad.Error import Hint.Base import Hint.Parsers import Hint.Conversions import Hint.Sandbox import qualified Hint.Compat as Compat -- | Returns a string representation of the type of the expression. typeOf :: MonadInterpreter m => String -> m String typeOf = sandboxed typeOf_unsandboxed typeOf_unsandboxed :: MonadInterpreter m => String -> m String typeOf_unsandboxed 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 Compat.exprType expr -- fromGhcRep ty -- | Tests if the expression type checks. typeChecks :: MonadInterpreter m => String -> m Bool typeChecks = sandboxed typeChecks_unsandboxed typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool typeChecks_unsandboxed expr = (typeOf_unsandboxed expr >> return True) `catchError` onCompilationError (\_ -> return False) -- | Returns a string representation of the kind of the type expression. kindOf :: MonadInterpreter m => String -> m String kindOf = sandboxed go where go 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 Compat.typeKind type_expr -- return $ fromGhcRep_ (Compat.Kind kind) onCompilationError :: MonadInterpreter m => ([GhcError] -> m a) -> (InterpreterError -> m a) onCompilationError recover = \interp_error -> case interp_error of WontCompile errs -> recover errs otherErr -> throwError otherErr hint-0.3.3.6/src/Hint/Typecheck.hs-boot0000644000000000000000000000020312117644541015716 0ustar0000000000000000module Hint.Typecheck where import Hint.Base (MonadInterpreter) typeChecks_unsandboxed :: MonadInterpreter m => String -> m Bool hint-0.3.3.6/src/Hint/Util.hs0000644000000000000000000000205112117644541013756 0ustar0000000000000000module 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 xs = foldr (select prop) ([],[]) xs 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) infixr 1 >=> (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \x -> f x >>= g quote :: String -> String quote s = concat ["'", s, "'"] hint-0.3.3.6/src/Language/0000755000000000000000000000000012117644541013330 5ustar0000000000000000hint-0.3.3.6/src/Language/Haskell/0000755000000000000000000000000012117644541014713 5ustar0000000000000000hint-0.3.3.6/src/Language/Haskell/Interpreter.hs0000644000000000000000000000376612117644541017566 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Interpreter -- License : BSD-style -- -- Maintainer : jcpetruzza@gmail.com -- 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, glasgowExtensions, Extension(..), installedModulesInScope, searchPath, setUseLanguageExtensions, setInstalledModsAreInScopeQualified, -- ** Context handling ModuleName, isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, -- ** Module querying ModuleElem(..), Id, name, children, getModuleExports, #if __GLASGOW_HASKELL__ >= 611 -- ** Anotations -- | Please note below that annotations are an experimental -- feature in GHC HEAD. -- 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, #endif -- ** Type inference typeOf, typeChecks, kindOf, -- ** Evaluation interpret, as, infer, eval, -- * Error handling InterpreterError(..), GhcError(..), MultipleInstancesNotAllowed(..), -- * Miscellaneous ghcVersion,parens, module Control.Monad.Trans) where import Hint.Base #if __GLASGOW_HASKELL__ >= 611 import Hint.Annotations #endif import Hint.InterpreterT import Hint.Configuration import Hint.Context import Hint.Reflection import Hint.Typecheck import Hint.Eval import Control.Monad.Trans hint-0.3.3.6/src/Language/Haskell/Interpreter/0000755000000000000000000000000012117644541017216 5ustar0000000000000000hint-0.3.3.6/src/Language/Haskell/Interpreter/Extension.hs0000644000000000000000000000014612117644541021527 0ustar0000000000000000module Language.Haskell.Interpreter.Extension ( module Hint.Extension ) where import Hint.Extension hint-0.3.3.6/src/Language/Haskell/Interpreter/GHC.hs0000644000000000000000000000064512117644541020160 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead. ----------------------------------------------------------------------------- module Language.Haskell.Interpreter.GHC {-# DEPRECATED "Import Language.Haskell.Interpreter instead." #-} ( module Language.Haskell.Interpreter ) where import Language.Haskell.Interpreter hint-0.3.3.6/src/Language/Haskell/Interpreter/Unsafe.hs0000644000000000000000000000202312117644541020770 0ustar0000000000000000module Language.Haskell.Interpreter.Unsafe ( unsafeSetGhcOption, unsafeRunInterpreterWithArgs ) where import Control.Monad.CatchIO import Hint.Base 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 :: (MonadCatchIO m, Functor m) => [String] -> InterpreterT m a -> m (Either InterpreterError a) unsafeRunInterpreterWithArgs = runInterpreterWithArgs hint-0.3.3.6/src/Language/Haskell/Interpreter/GHC/0000755000000000000000000000000012117644541017617 5ustar0000000000000000hint-0.3.3.6/src/Language/Haskell/Interpreter/GHC/Unsafe.hs0000644000000000000000000000070112117644541021372 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- DEPRECATED: use @Language.Haskell.Interpreter.Unsafe@ instead. ----------------------------------------------------------------------------- module Language.Haskell.Interpreter.GHC.Unsafe {-# DEPRECATED "Import Language.Haskell.Interpreter.Unsafe instead." #-} ( module Language.Haskell.Interpreter.Unsafe ) where import Language.Haskell.Interpreter.Unsafe hint-0.3.3.6/unit-tests/0000755000000000000000000000000012117644541013135 5ustar0000000000000000hint-0.3.3.6/unit-tests/run-unit-tests.hs0000644000000000000000000002636412117644541016425 0ustar0000000000000000module Main ( main ) where import Prelude hiding (catch) import Control.Exception.Extensible ( ArithException(..), finally ) import Control.Monad.CatchIO ( catch, throw ) import Control.Monad ( liftM, when ) import Control.Monad.Error ( Error, MonadError(catchError) ) import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar import System.IO import System.FilePath import System.Directory import System.Exit 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 "f" (as :: Int -> Int) 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 "f $ 1 == 2" infer @@?= 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 expr (as :: Int) 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" return () test_basic_eval :: TestCase test_basic_eval = TestCase "basic_eval" [] $ do eval "()" @@?= "()" test_eval_layout :: TestCase test_eval_layout = TestCase "eval_layout" [] $ do 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 = throw e action = do s <- eval "1 `div` 0 :: Int" return $! s test_only_one_instance :: TestCase test_only_one_instance = TestCase "only_one_instance" [] $ do liftIO $ do r <- newEmptyMVar let concurrent = runInterpreter (liftIO $ putMVar r False) `catch` \MultipleInstancesNotAllowed -> do liftIO $ putMVar r True return $ Right () _ <- forkIO $ concurrent >> return () readMVar r @? "concurrent instance did not fail" tests :: [TestCase] tests = [test_reload_modified, test_lang_exts, test_work_in_main, test_comments_in_expr, test_qual_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] main :: IO () main = do -- run the tests... c <- runTests False tests -- then run again, but with sandboxing on... c' <- runTests True tests -- let failures = HUnit.errors c + HUnit.failures c + HUnit.errors c' + HUnit.failures c' exit_code | failures > 0 = ExitFailure failures | otherwise = ExitSuccess exitWith exit_code -- `catch` (\_ -> exitWith (ExitFailure $ -1)) printInterpreterError :: InterpreterError -> IO () printInterpreterError = hPutStrLn stderr . show setSandbox :: Interpreter () setSandbox = set [installedModulesInScope := False] (>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) f >=> g = \a -> f a >>= g (@@?) :: (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 :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool fails action = (action >> return False) `catchError` (\_ -> return True) succeeds :: (Error e, MonadError e m, MonadIO m) => m a -> m Bool succeeds = liftM not . fails data TestCase = TestCase String [FilePath] (Interpreter ()) runTests :: Bool -> [TestCase] -> IO HUnit.Counts runTests sandboxed = HUnit.runTestTT . HUnit.TestList . map build where build (TestCase title tmps test) = HUnit.TestLabel title $ HUnit.TestCase test_case where test_case = go `finally` clean_up clean_up = mapM_ removeIfExists tmps go = do r <- runInterpreter (when sandboxed setSandbox >> test) 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