diff --git a/ErrMsg.hs b/ErrMsg.hs index b2d2df2..30d9270 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 = df { log_action = \_ _ _ _ _ -> return () } setLogger True df = do ref <- newIORef [] :: IO (IORef [String]) let newdf = df { log_action = 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 -> Message -> 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 16a1abe..e98828e 100644 --- a/Gap.hs +++ b/Gap.hs @@ -78,7 +78,7 @@ getSrcFile _ = Nothing renderMsg :: SDoc -> PprStyle -> String #if __GLASGOW_HASKELL__ >= 702 -renderMsg d stl = renderWithStyle d stl +renderMsg d stl = renderWithStyle tracingDynFlags d stl #else renderMsg d stl = Pretty.showDocWith PageMode $ d stl #endif @@ -109,15 +109,15 @@ fOptions = [option | (option,_,_) <- fFlags] ---------------------------------------------------------------- setCtx :: [ModSummary] -> Ghc Bool -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 70 setCtx ms = do - top <- map (IIModule . ms_mod) <$> filterM isTop ms + top <- map (IIModule . moduleName . ms_mod) <$> filterM isTop ms setContext top return (not . null $ top) #else setCtx ms = do - top <- map ms_mod <$> filterM isTop ms - setContext top [] + top <- map (IIModule . ms_mod) <$> filterM isTop ms + setContext top return (not . null $ top) #endif where diff --git a/Info.hs b/Info.hs index 4143699..618bb3c 100644 --- a/Info.hs +++ b/Info.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances, RankNTypes #-} module Info (infoExpr, typeExpr) where @@ -10,6 +10,7 @@ import Data.Generics import Data.List import Data.Maybe import Data.Ord as O +import DynFlags (tracingDynFlags) import Desugar import GHC import GHC.SYB.Utils @@ -106,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 (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False +pretty = showDocWith OneLineMode . withPprStyleDoc tracingDynFlags (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs @@ -125,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, [Instance]) -> SDoc pprInfo pefas (thing, fixity, insts) = pprTyThingInContextLoc pefas thing $$ show_fixity fixity