hint 0.3.1.0 → 0.3.2.0

raw patch · 12 files changed

+225/−49 lines, 12 filesdep +extensible-exceptionsdep ~MonadCatchIO-mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: extensible-exceptions

Dependency ranges changed: MonadCatchIO-mtl

API changes (from Hackage documentation)

Files

• AUTHORS +4/−0
• Changes +13/−0
• hint.cabal +7/−3
• src/Hint/Annotations.hs +72/−0
• src/Hint/Base.hs +2/−2
• src/Hint/Compat/Exceptions.hs +0/−27
• src/Hint/Configuration.hs +18/−3
• src/Hint/Context.hs +5/−1
• src/Hint/Eval.hs +3/−4
• src/Hint/InterpreterT.hs +6/−1
• src/Language/Haskell/Interpreter.hs +15/−3
• unit-tests/run-unit-tests.hs +80/−5

@@ -3,3 +3,7 @@ Contributions from: Evan Laforge Gwern Branwen+Jean Philippe Bernardy+Austin Seipp+Fernando Benavides+Pasqualino Titto Assini

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

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

@@ -0,0 +1,72 @@+-- - extract annotations from modules etc. with the GHC API.+-- - requires GHC >= 6.11+--+-- austin seipp <as@nijoruj.org>+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)

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

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

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

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

@@ -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, ")"]

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

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

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