diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -3,3 +3,7 @@ Contributions from: Evan Laforge Gwern Branwen +Jean Philippe Bernardy +Austin Seipp +Fernando Benavides +Pasqualino Titto Assini diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -1,3 +1,16 @@ +- 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. diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -1,5 +1,5 @@ name: hint -version: 0.3.1.0 +version: 0.3.2.0 description: This library defines an @Interpreter@ monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -36,7 +36,8 @@ mtl, filepath, utf8-string, - MonadCatchIO-mtl + extensible-exceptions, + MonadCatchIO-mtl >= 0.2 if impl(ghc >= 6.8) { build-depends: random, directory @@ -61,7 +62,6 @@ Hint.Base Hint.InterpreterT Hint.Compat - Hint.Compat.Exceptions Hint.Configuration Hint.Extension Hint.Context @@ -72,6 +72,10 @@ Hint.Typecheck Hint.Sandbox Hint.Util + + if impl(ghc >= 6.11) { + other-modules: Hint.Annotations + } hs-source-dirs: src 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,72 @@ +-- - 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) diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -18,14 +18,13 @@ where import Control.Monad.Error +import Control.Monad.CatchIO import Data.IORef import Data.Dynamic import qualified Hint.GHC as GHC -import Hint.Compat.Exceptions - import Hint.Extension -- | Version of the underlying ghc api. Values are: @@ -71,6 +70,7 @@ configuration :: InterpreterConfiguration} data InterpreterConfiguration = Conf { + search_path :: [FilePath], language_exts :: [Extension], all_mods_in_scope :: Bool } diff --git a/src/Hint/Compat/Exceptions.hs b/src/Hint/Compat/Exceptions.hs deleted file mode 100644 --- a/src/Hint/Compat/Exceptions.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hint.Compat.Exceptions ( -#if __GLASGOW_HASKELL__ >= 610 - module Control.Monad.CatchIO -#else - throw, catch, - module Control.Monad.CatchIO.Old -#endif - -) - -where - -import Prelude hiding ( catch ) - -#if __GLASGOW_HASKELL__ >= 610 -import Control.Monad.CatchIO -#else -import Data.Dynamic - -import Control.Monad.CatchIO.Old hiding ( throw, catch ) - -throw :: Typeable e => e -> a -throw = throwDyn - -catch :: (Typeable e, MonadCatchIO m) => m a -> (e -> m a) -> m a -catch = catchDyn -#endif diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -11,11 +11,13 @@ setUseLanguageExtensions, - setInstalledModsAreInScopeQualified ) where + setInstalledModsAreInScopeQualified, + searchPath + ) where import Control.Monad.Error import Data.Char -import Data.List ( intersect ) +import Data.List ( intersect, intercalate ) import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat @@ -40,7 +42,8 @@ defaultConf :: InterpreterConfiguration defaultConf = Conf { language_exts = [], - all_mods_in_scope = False + all_mods_in_scope = False, + search_path = ["."] } @@ -148,6 +151,18 @@ 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) diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -1,6 +1,6 @@ module Hint.Context ( - ModuleName, + ModuleName, isModuleInterpreted, loadModules, getLoadedModules, setTopLevelModules, setImports, setImportsQ, reset, @@ -156,6 +156,10 @@ -- 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] diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs --- a/src/Hint/Eval.hs +++ b/src/Hint/Eval.hs @@ -1,7 +1,7 @@ module Hint.Eval ( interpret, as, infer, - eval ) + eval ,parens) where @@ -56,15 +56,14 @@ let show_expr = unwords [in_scope_show, parens expr] unsafeInterpret show_expr in_scope_String --- Conceptually, @parens s = "(" ++ s ++ ")"@, where s is some valid haskell +-- | Conceptually, @parens s = \"(\" ++ s ++ \")\"@, where s is some 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 = " ++ s ++ --- " ;} in foo)@ where foo does not occur in s +-- Solution: @parens s = \"(let {foo = \" ++ s ++ \"\\n ;} in foo)\"@ where @foo@ does not occur in @s@ parens :: String -> String parens s = concat ["(let {", foo, " = ", s, "\n", " ;} in ", foo, ")"] diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -10,8 +10,10 @@ import Hint.Context import Hint.Configuration +import Control.Applicative import Control.Monad.Reader import Control.Monad.Error +import Control.Monad.CatchIO import Data.IORef #if __GLASGOW_HASKELL__ < 610 @@ -22,7 +24,6 @@ import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat -import Hint.Compat.Exceptions type Interpreter = InterpreterT IO @@ -166,3 +167,7 @@ catchError (InterpreterT m) catchE = InterpreterT $ m `catchError` (\e -> unInterpreterT $ catchE e) + +instance Monad m => Applicative (InterpreterT m) where + pure = return + (<*>) = ap diff --git a/src/Language/Haskell/Interpreter.hs b/src/Language/Haskell/Interpreter.hs --- a/src/Language/Haskell/Interpreter.hs +++ b/src/Language/Haskell/Interpreter.hs @@ -18,18 +18,27 @@ Option, OptionVal((:=)), get, set, languageExtensions, availableExtensions, glasgowExtensions, Extension(..), - installedModulesInScope, + installedModulesInScope, searchPath, setUseLanguageExtensions, setInstalledModsAreInScopeQualified, -- ** Context handling - ModuleName, + 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 @@ -37,12 +46,15 @@ -- * Error handling InterpreterError(..), GhcError(..), -- * Miscellaneous - ghcVersion, + 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 diff --git a/unit-tests/run-unit-tests.hs b/unit-tests/run-unit-tests.hs --- a/unit-tests/run-unit-tests.hs +++ b/unit-tests/run-unit-tests.hs @@ -2,12 +2,14 @@ import Prelude hiding (catch) -import Control.Exception +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 System.IO +import System.FilePath import System.Directory import System.Exit @@ -121,6 +123,72 @@ 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 + + + tests :: [TestCase] tests = [test_reload_modified, test_lang_exts, @@ -130,7 +198,10 @@ test_basic_eval, test_show_in_scope, test_installed_not_in_scope, - test_priv_syms_in_scope] + test_priv_syms_in_scope, + test_search_path, + test_search_path_dot, + test_catch] main :: IO () main = do -- run the tests... @@ -180,6 +251,10 @@ (when sandboxed setSandbox >> test) either (printInterpreterError >=> (fail . show)) return r - removeIfExists f = do exists <- doesFileExist f - when exists $ - removeFile f + removeIfExists f = do existsF <- doesFileExist f + if existsF + then removeFile f + else + do existsD <- doesDirectoryExist f + when existsD $ + removeDirectory f