diff --git a/Changes b/Changes --- a/Changes +++ b/Changes @@ -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...) diff --git a/hint.cabal b/hint.cabal --- a/hint.cabal +++ b/hint.cabal @@ -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 diff --git a/src/Hint/Base.hs b/src/Hint/Base.hs --- a/src/Hint/Base.hs +++ b/src/Hint/Base.hs @@ -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 { diff --git a/src/Hint/Compat.hs b/src/Hint/Compat.hs --- a/src/Hint/Compat.hs +++ b/src/Hint/Compat.hs @@ -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 diff --git a/src/Hint/Configuration.hs b/src/Hint/Configuration.hs --- a/src/Hint/Configuration.hs +++ b/src/Hint/Configuration.hs @@ -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", diff --git a/src/Hint/Context.hs b/src/Hint/Context.hs --- a/src/Hint/Context.hs +++ b/src/Hint/Context.hs @@ -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 ++ "( ", diff --git a/src/Hint/Extension.hs b/src/Hint/Extension.hs --- a/src/Hint/Extension.hs +++ b/src/Hint/Extension.hs @@ -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 ] diff --git a/src/Hint/GHC.hs b/src/Hint/GHC.hs --- a/src/Hint/GHC.hs +++ b/src/Hint/GHC.hs @@ -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 ) diff --git a/src/Hint/InterpreterT.hs b/src/Hint/InterpreterT.hs --- a/src/Hint/InterpreterT.hs +++ b/src/Hint/InterpreterT.hs @@ -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 :) diff --git a/src/Hint/Parsers.hs b/src/Hint/Parsers.hs --- a/src/Hint/Parsers.hs +++ b/src/Hint/Parsers.hs @@ -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 "") 1 1 + let parse_res = GHC.unP parser (Compat.mkPState dyn_fl buf srcLoc) -- case parse_res of GHC.POk{} -> return ParseOk diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs --- a/src/Hint/Util.hs +++ b/src/Hint/Util.hs @@ -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, "'"] 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 @@ -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"