hint 0.3.3.1 → 0.3.3.2

raw patch · 12 files changed

+175/−69 lines, 12 filesdep ~basedep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• Changes +3/−0
• hint.cabal +1/−1
• src/Hint/Base.hs +1/−0
• src/Hint/Compat.hs +28/−0
• src/Hint/Configuration.hs +20/−23
• src/Hint/Context.hs +16/−17
• src/Hint/Extension.hs +49/−3
• src/Hint/GHC.hs +7/−0
• src/Hint/InterpreterT.hs +33/−19
• src/Hint/Parsers.hs +4/−1
• src/Hint/Util.hs +8/−0
• unit-tests/run-unit-tests.hs +5/−5

@@ -1,3 +1,6 @@+- 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...)

@@ -1,5 +1,5 @@ name:                hint-version:             0.3.3.1+version:             0.3.3.2 description:         This library defines an @Interpreter@ monad. It allows to load Haskell         modules, browse them, type-check and evaluate strings with Haskell

@@ -67,6 +67,7 @@                            hint_support_module  :: PhantomModule,                            import_qual_hack_mod :: Maybe PhantomModule,                            qual_imports         :: [(ModuleName, String)],+                           defaultExts          :: [(Extension,Bool)], -- R/O                            configuration        :: InterpreterConfiguration}  data InterpreterConfiguration = Conf {

@@ -1,3 +1,5 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Hint.Compat  where@@ -7,6 +9,32 @@ -- 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 (\(e,_,_) -> e) GHC.xFlags++-- 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++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+  #if __GLASGOW_HASKELL__ >= 610 configureDynFlags :: GHC.DynFlags -> GHC.DynFlags

@@ -22,7 +22,7 @@ import qualified Hint.GHC as GHC import qualified Hint.Compat as Compat import Hint.Base-import Hint.Util ( partition )+import Hint.Util ( quote )  import Hint.Extension @@ -31,8 +31,9 @@     do old_flags <- runGhc GHC.getSessionDynFlags        (new_flags,not_parsed) <- runGhc2 Compat.parseDynamicFlags old_flags opts        when (not . null $ not_parsed) $-            throwError $ UnknownError (concat ["flag: '", unwords opts,-                                               "' not recognized"])+            throwError $ UnknownError+                            $ concat ["flags: ", unwords $ map quote not_parsed,+                                               "not recognized"]        _ <- runGhc1 GHC.setSessionDynFlags new_flags        return () @@ -52,6 +53,8 @@ --    * 'languageExtensions' -- --    * 'installedModulesInScope'+--+--    * 'searchPath' data Option m a = Option{_set :: MonadInterpreter m => a -> m (),                          _get :: MonadInterpreter m => m a} @@ -73,37 +76,31 @@ -- Default is: @[]@ (i.e. none, pure Haskell 98) languageExtensions :: MonadInterpreter m => Option m [Extension] languageExtensions = Option setter getter-    where setter es = do setGhcOptions $ map (mkFlag False) availableExtensions-                         setGhcOptions $ map (mkFlag True)  es+    where setter es = do resetExtensions+                         setGhcOptions $ map (extFlag True)  es                          onConf $ \c -> c{language_exts = es}           --           getter = fromConf language_exts           ---          mkFlag b (UnknownExtension o) = "-X" ++ concat ["No"|not b] ++ o-          mkFlag b o-            | ('N':'o':c:_) <- show o,-              isUpper c                 = if b-                                            then "-X" ++ show o-                                            else "-X" ++ (drop 2 $ show o)-            | otherwise                 = "-X" ++ concat ["No"|not b] ++ show o+          resetExtensions = do es <- fromState defaultExts+                               setGhcOptions $ map (uncurry $ flip extFlag) es --- | List of the extensions known by the interpreter.-availableExtensions :: [Extension]-availableExtensions = asExtensionList GHC.supportedLanguages+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 -asExtensionList :: [String] -> [Extension]-asExtensionList exts = map read knownPos                  ++-                       map read (map ("No" ++) knownNegs) ++-                       map UnknownExtension unknown-    where (knownPos, unknownPos) = partition isKnown exts-          (knownNegs,unknown)    = partition (isKnown . ("No" ++)) unknownPos-          isKnown e = e `elem` map show knownExtensions   -- | 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 = asExtensionList ["PrintExplicitForalls",+    where exts612 = map asExtension ["PrintExplicitForalls",                                      "ForeignFunctionInterface",                                      "UnliftedFFITypes",                                      "GADTs",

@@ -19,7 +19,6 @@  import Data.Char import Data.List-import Data.Maybe  import Control.Monad       ( liftM, filterM, when, guard ) import Control.Monad.Error ( catchError, throwError, liftIO )@@ -58,7 +57,7 @@  allModulesInContext :: MonadInterpreter m => m ([ModuleName], [ModuleName]) allModulesInContext =-    do (l, i) <- runGhc GHC.getContext+    do (l, i) <- runGhc Compat.getContext        return (map fromGhcRep_ l, map fromGhcRep_ i)  addPhantomModule :: MonadInterpreter m@@ -74,13 +73,13 @@        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 GHC.getContext+                   (old_top, old_imps) <- runGhc Compat.getContext                    --                    runGhc1 GHC.addTarget t                    res <- runGhc1 GHC.load (GHC.LoadUpTo m)                    --                    if isSucceeded res-                     then do runGhc2 GHC.setContext old_top old_imps+                     then do runGhc2 Compat.setContext old_top old_imps                              return $ Just ()                      else return Nothing)         `catchError` (\err -> case err of@@ -105,9 +104,9 @@            if isLoaded              then do -- take it out of scope                      mod <- findModule (pm_name pm)-                     (mods, imps) <- runGhc GHC.getContext+                     (mods, imps) <- runGhc Compat.getContext                      let mods' = filter (mod /=) mods-                     runGhc2 GHC.setContext mods' imps+                     runGhc2 Compat.setContext mods' imps                      --                      let isNotPhantom = isPhantomModule . fromGhcRep_  >=>                                           return . not@@ -197,14 +196,14 @@          throwError $ NotAllowed ("These modules are not interpreted:\n" ++                                   unlines (map fromGhcRep_ not_interpreted))        ---       (_, old_imports) <- runGhc GHC.getContext-       runGhc2 GHC.setContext ms_mods old_imports+       (_, 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 GHC.getContext-       runGhc2 GHC.setContext [] []-       let restore = runGhc2 GHC.setContext old_mods old_imps+    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@@ -227,8 +226,8 @@ --   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 (q,     u) = Util.partition (isJust . snd) ms-           (quals, unquals) = (map (\(a, Just b) -> (a,b)) q, map fst u)+    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@@ -247,9 +246,9 @@                    else return Nothing        --        pm <- maybe (return []) (findModule . pm_name >=> return . return) new_pm-       (old_top_level, _) <- runGhc GHC.getContext+       (old_top_level, _) <- runGhc Compat.getContext        let new_top_level = pm ++ old_top_level-       runGhc2 GHC.setContext new_top_level unqual_mods+       runGhc2 Compat.setContext new_top_level unqual_mods        --        onState (\s ->s{qual_imports = quals}) @@ -260,7 +259,7 @@ reset :: MonadInterpreter m => m () reset =     do -- Remove all modules from context-       runGhc2 GHC.setContext [] []+       runGhc2 Compat.setContext [] []        --        -- Unload all previously loaded modules        runGhc1 GHC.setTargets []@@ -289,7 +288,7 @@ installSupportModule = do mod <- addPhantomModule support_module                           onState (\st -> st{hint_support_module = mod})                           mod' <- findModule (pm_name mod)-                          runGhc2 GHC.setContext [mod'] []+                          runGhc2 Compat.setContext [mod'] []     --     where support_module m = unlines [                                "module " ++ m ++ "( ",

@@ -1,12 +1,31 @@ -- this module was automatically generated. do not edit!-module Hint.Extension (Extension(..), knownExtensions)+-- edit util/mk_extensions_mod.hs instead+module Hint.Extension (Extension(..),+                       knownExtensions, availableExtensions, asExtension)  where --- | This represents language extensions beyond Haskell 98      that are supported by GHC (it was taken from      Cabal's @Language.Haskell.Extension@)+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@@ -62,6 +81,19 @@                | QuasiQuotes                | TransformListComp                | ViewPatterns+               | XmlSyntax+               | RegularPatterns+               | TupleSections+               | GHCForeignImportPrim+               | NPlusKPatterns+               | DoAndIfThenElse+               | RebindableSyntax+               | ExplicitForAll+               | DatatypeContexts+               | MonoLocalBinds+               | DeriveFunctor+               | DeriveTraversable+               | DeriveFoldable                | UnknownExtension String         deriving (Eq, Show, Read) @@ -69,6 +101,7 @@ knownExtensions = [OverlappingInstances,                    UndecidableInstances,                    IncoherentInstances,+                   DoRec,                    RecursiveDo,                    ParallelListComp,                    MultiParamTypeClasses,@@ -123,5 +156,18 @@                    PostfixOperators,                    QuasiQuotes,                    TransformListComp,-                   ViewPatterns+                   ViewPatterns,+                   XmlSyntax,+                   RegularPatterns,+                   TupleSections,+                   GHCForeignImportPrim,+                   NPlusKPatterns,+                   DoAndIfThenElse,+                   RebindableSyntax,+                   ExplicitForAll,+                   DatatypeContexts,+                   MonoLocalBinds,+                   DeriveFunctor,+                   DeriveTraversable,+                   DeriveFoldable                    ]

@@ -8,6 +8,7 @@     module Lexer,     module Parser,     module DynFlags,+    module FastString, #if __GLASGOW_HASKELL__ >= 610     module Control.Monad.Ghc,     module HscTypes,@@ -40,7 +41,13 @@ import StringBuffer ( stringToStringBuffer ) import Lexer        ( P(..), ParseResult(..), mkPState ) import Parser       ( parseStmt, parseType )+import FastString   ( fsLit )++#if __GLASGOW_HASKELL__ >= 700+import DynFlags     ( xFlags, xopt )+#else import DynFlags     ( supportedLanguages )+#endif  #if __GLASGOW_HASKELL__ >= 608 import PprTyThing   ( pprTypeForUser )

@@ -10,6 +10,7 @@ import Hint.Base import Hint.Context import Hint.Configuration+import Hint.Extension  import Control.Applicative import Control.Monad.Reader@@ -22,6 +23,7 @@  import Data.IORef import Data.List+import Data.Maybe #if __GLASGOW_HASKELL__ < 610 import Data.Dynamic #endif@@ -102,24 +104,34 @@ initialize args =     do log_handler <- fromSession ghcErrLogger        -- Set a custom log handler, to intercept error messages :S-       dflags <- runGhc GHC.getSessionDynFlags--       dflags' <- do-           let df = Compat.configureDynFlags dflags+       df0 <- runGhc GHC.getSessionDynFlags -           (df', extra) <- runGhc2 Compat.parseDynamicFlags df args-           when (not . null $ extra) $-               throwError $ UnknownError (concat [ "flags: '"-                                                 , intercalate " " extra-                                                 , "' not recognized"])-           return df'+       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 dflags'{GHC.log_action = log_handler}+       _ <- runGhc1 GHC.setSessionDynFlags df2{GHC.log_action = log_handler} +#if __GLASGOW_HASKELL__ >= 700+       let extMap      = map (\(a,b,_) -> (a,b)) GHC.xFlags+       let toOpt e     = let err = error ("init error: unknown ext:" ++ show e)+                         in fromMaybe err (lookup e extMap)+       let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2)+       let defExts = map  getOptVal 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@@ -180,18 +192,20 @@                    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-                              }+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 _ src style msg = modifyIORef r (errorEntry :)

@@ -5,6 +5,7 @@ import Prelude hiding(span)  import Hint.Base+import qualified Hint.Compat as Compat  import Control.Monad.Trans ( liftIO ) @@ -24,7 +25,9 @@        --        buf <- liftIO $ GHC.stringToStringBuffer expr        ---       let parse_res = GHC.unP parser (GHC.mkPState buf GHC.noSrcLoc dyn_fl)+       -- ghc >= 7 panics if noSrcLoc is given+       let srcLoc = GHC.mkSrcLoc (GHC.fsLit "<hint>") 1 1+       let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc)        --        case parse_res of            GHC.POk{}            -> return ParseOk

@@ -18,7 +18,15 @@     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, "'"]

@@ -53,7 +53,7 @@                       liftIO $ writeFile mod_file "data T where T :: T"                       fails do_load @@? "first time, it shouldn't load"                       ---                      set [languageExtensions := glasgowExtensions]+                      set [languageExtensions := [GADTs]]                       succeeds do_load @@? "now, it should load"                       --                       set [languageExtensions := []]@@ -72,7 +72,7 @@                         setImportsQ [("Prelude",Nothing),                                        ("Data.Maybe", Just "Mb")]                         ---                        typeOf "f $ 1+1" @@?= "(Num a) => a"+                        typeOf "f $ (1 + 1 :: Int)" @@?= "Int"                         eval "f . Mb.fromJust $ Just [1,2]" @@?= "[1,2]"                         interpret "f $ 1 == 2" infer @@?= False     --@@ -95,8 +95,8 @@                             setImports ["Prelude"]                             let expr = "length $ concat [[1,2],[3]] -- bla"                             typeChecks expr @@? "comment on expression"-                            eval expr-                            interpret expr (as :: Int)+                            _ <- eval expr+                            _ <- interpret expr (as :: Int)                             return ()  test_qual_import :: TestCase@@ -206,7 +206,7 @@                           `catch` \MultipleInstancesNotAllowed ->                                     do liftIO $ putMVar r True                                        return $ Right ()-        forkIO $ concurrent >> return ()+        _ <- forkIO $ concurrent >> return ()         readMVar r @?  "concurrent instance did not fail"