partial change set for ghc 7.6 api change, needs some more work though.
This commit is contained in:
parent
e284080fca
commit
f7a7c67bcb
@ -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
|
||||
|
10
Gap.hs
10
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
|
||||
|
7
Info.hs
7
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
|
||||
|
Loading…
Reference in New Issue
Block a user