diff --git a/Check.hs b/Check.hs index 0baa26e..f891ae7 100644 --- a/Check.hs +++ b/Check.hs @@ -7,7 +7,7 @@ import ErrMsg import Exception import GHC import GHCApi -import Prelude hiding (catch) +import Prelude import Types ---------------------------------------------------------------- diff --git a/ErrMsg.hs b/ErrMsg.hs index 30d9270..6d92e7a 100644 --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -24,13 +24,13 @@ type LogReader = IO [String] setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader) setLogger False df = return (newdf, undefined) where - newdf = df { log_action = \_ _ _ _ _ -> return () } + newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () setLogger True df = do ref <- newIORef [] :: IO (IORef [String]) - let newdf = df { log_action = appendLog ref } + let newdf = Gap.setLogAction df $ appendLog ref return (newdf, reverse <$> readIORef ref) where - appendLog ref _ _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls) + appendLog ref _ _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls) ---------------------------------------------------------------- @@ -49,7 +49,7 @@ ppErrMsg err = ppMsg spn msg defaultUserStyle ++ ext msg = errMsgShortDoc err ext = showMsg (errMsgExtraInfo err) defaultUserStyle ---ppMsg :: SrcSpan -> Message -> PprStyle -> String +ppMsg :: SrcSpan -> SDoc -> PprStyle -> String ppMsg spn msg stl = fromMaybe def $ do (line,col,_,_) <- Gap.getSrcSpan spn file <- Gap.getSrcFile spn diff --git a/Gap.hs b/Gap.hs index e98828e..dcda6b2 100644 --- a/Gap.hs +++ b/Gap.hs @@ -1,7 +1,13 @@ {-# LANGUAGE CPP #-} module Gap ( - supportedExtensions + Gap.ClsInst + , mkTarget + , showDocForUser + , showDoc + , styleDoc + , setLogAction + , supportedExtensions , getSrcSpan , getSrcFile , renderMsg @@ -18,7 +24,9 @@ module Gap ( import Control.Applicative hiding (empty) import Control.Monad +import Data.Time.Clock import DynFlags +import ErrUtils import FastString import GHC import GHCChoice @@ -26,6 +34,11 @@ import Language.Haskell.Extension import Outputable import StringBuffer +import qualified InstEnv +import qualified Pretty +import qualified StringBuffer as SB + + #if __GLASGOW_HASKELL__ >= 702 import CoreMonad (liftIO) #else @@ -33,6 +46,11 @@ import HscTypes (liftIO) import Pretty #endif +#if __GLASGOW_HASKELL__ < 706 +import Control.Arrow +import Data.Convertible +#endif + {- pretty :: Outputable a => a -> String pretty = showSDocForUser neverQualify . ppr @@ -41,6 +59,56 @@ debug :: Outputable a => a -> b -> b debug x v = trace (pretty x) v -} +---------------------------------------------------------------- +---------------------------------------------------------------- +-- +#if __GLASGOW_HASKELL__ >= 706 +type ClsInst = InstEnv.ClsInst +#else +type ClsInst = InstEnv.Instance +#endif + +mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target +#if __GLASGOW_HASKELL__ >= 706 +mkTarget = Target +#else +mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +showDocForUser :: PrintUnqualified -> SDoc -> String +#if __GLASGOW_HASKELL__ >= 706 +showDocForUser = showSDocForUser tracingDynFlags +#else +showDocForUser = showSDocForUser +#endif + +showDoc :: SDoc -> String +#if __GLASGOW_HASKELL__ >= 706 +showDoc = showSDoc tracingDynFlags +#else +showDoc = showSDoc +#endif + +styleDoc :: PprStyle -> SDoc -> Pretty.Doc +#if __GLASGOW_HASKELL__ >= 706 +styleDoc = withPprStyleDoc tracingDynFlags +#else +styleDoc = withPprStyleDoc +#endif + +setLogAction :: DynFlags + -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()) + -> DynFlags +setLogAction df f = +#if __GLASGOW_HASKELL__ >= 706 + df { log_action = f } +#else + df { log_action = f df } +#endif + ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -77,8 +145,10 @@ getSrcFile _ = Nothing ---------------------------------------------------------------- renderMsg :: SDoc -> PprStyle -> String -#if __GLASGOW_HASKELL__ >= 702 -renderMsg d stl = renderWithStyle tracingDynFlags d stl +#if __GLASGOW_HASKELL__ >= 706 +renderMsg d stl = renderWithStyle tracingDynFlags d stl +#elif __GLASGOW_HASKELL__ >= 702 +renderMsg d stl = renderWithStyle d stl #else renderMsg d stl = Pretty.showDocWith PageMode $ d stl #endif @@ -109,15 +179,20 @@ fOptions = [option | (option,_,_) <- fFlags] ---------------------------------------------------------------- setCtx :: [ModSummary] -> Ghc Bool -#if __GLASGOW_HASKELL__ >= 70 +#if __GLASGOW_HASKELL__ >= 704 setCtx ms = do - top <- map (IIModule . moduleName . ms_mod) <$> filterM isTop ms +#if __GLASGOW_HASKELL__ >= 706 + let modName = IIModule . moduleName . ms_mod +#else + let modName = IIModule . ms_mod +#endif + top <- map modName <$> filterM isTop ms setContext top return (not . null $ top) #else setCtx ms = do - top <- map (IIModule . ms_mod) <$> filterM isTop ms - setContext top + top <- map ms_mod <$> filterM isTop ms + setContext top [] return (not . null $ top) #endif where diff --git a/Info.hs b/Info.hs index d65fd06..feb3c1a 100644 --- a/Info.hs +++ b/Info.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances, RankNTypes #-} +{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE Rank2Types #-} module Info (infoExpr, typeExpr) where @@ -11,7 +12,6 @@ import Data.List import Data.Maybe import Data.Ord as O import Data.Time.Clock -import DynFlags (tracingDynFlags) import Desugar import GHC import GHC.SYB.Utils @@ -23,7 +23,6 @@ import NameSet import Outputable import PprTyThing import Pretty (showDocWith, Mode(OneLineMode)) -import System.Time import TcRnTypes import TcHsSyn (hsPatType) import Types @@ -108,7 +107,7 @@ listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) pretty :: Type -> String -pretty = showDocWith OneLineMode . withPprStyleDoc tracingDynFlags (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False +pretty = showDocWith OneLineMode . Gap.styleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs @@ -119,7 +118,7 @@ infoThing str = do mb_stuffs <- mapM getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- getPrintUnqual - return $ showSDocForUser tracingDynFlags unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + return $ Gap.showDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs @@ -127,7 +126,7 @@ filterOutChildren get_thing xs where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] ---pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Instance]) -> SDoc +pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc pprInfo pefas (thing, fixity, insts) = pprTyThingInContextLoc pefas thing $$ show_fixity fixity @@ -155,13 +154,15 @@ inModuleContext opt fileName modstr action errmsg = doif setContextFromTarget action setTargetBuffer = do modgraph <- depanal [mkModuleName modstr] True - let imports = concatMap (map ((showSDoc tracingDynFlags) . ppr . unLoc)) $ + let imports = concatMap (map (Gap.showDoc . ppr . unLoc)) $ map ms_imps modgraph ++ map ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports importsBuf <- Gap.toStringBuffer header clkTime <- Gap.liftIO getCurrentTime - setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))] + setTargets [Gap.mkTarget (TargetModule $ mkModuleName modstr) + True + (Just (importsBuf, clkTime))] doif m t = m >>= \ok -> if ok then t else goNext sanitize = fromMaybe "SomeModule" . listToMaybe . words diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 20b77d8..880e14c 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -45,6 +45,7 @@ Executable ghc-mod GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5 , Cabal + , convertible , directory , filepath , ghc @@ -53,10 +54,10 @@ Executable ghc-mod , hlint >= 1.7.1 , io-choice , old-time - , time , process , regex-posix , syb + , time , transformers Source-Repository head