hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

partial change set for ghc 7.6 api change, needs some more work though.

Browse Source
This commit is contained in:
Carter Tazio Schonwald 2012-09-20 14:50:03 -04:00
parent e284080fca
commit f7a7c67bcb
3 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
ErrMsg.hs
View File

@ -24,13 +24,13 @@ type LogReader = IO [String]
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader) setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined) setLogger False df = return (newdf, undefined)
where where
newdf = df { log_action = \_ _ _ _ -> return () } newdf = df { log_action = \_ _ _ _ _ -> return () }
setLogger True df = do setLogger True df = do
ref <- newIORef [] :: IO (IORef [String]) ref <- newIORef [] :: IO (IORef [String])
let newdf = df { log_action = appendLog ref } let newdf = df { log_action = appendLog ref }
return (newdf, reverse <$> readIORef ref) return (newdf, reverse <$> readIORef ref)
where 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 msg = errMsgShortDoc err
ext = showMsg (errMsgExtraInfo err) defaultUserStyle ext = showMsg (errMsgExtraInfo err) defaultUserStyle
ppMsg :: SrcSpan -> Message -> PprStyle -> String --ppMsg :: SrcSpan -> Message -> PprStyle -> String
ppMsg spn msg stl = fromMaybe def $ do ppMsg spn msg stl = fromMaybe def $ do
(line,col,_,_) <- Gap.getSrcSpan spn (line,col,_,_) <- Gap.getSrcSpan spn
file <- Gap.getSrcFile spn file <- Gap.getSrcFile spn

10
Gap.hs
View File

@ -78,7 +78,7 @@ getSrcFile _ = Nothing
renderMsg :: SDoc -> PprStyle -> String renderMsg :: SDoc -> PprStyle -> String
#if __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 702
renderMsg d stl = renderWithStyle d stl renderMsg d stl = renderWithStyle tracingDynFlags d stl
#else #else
renderMsg d stl = Pretty.showDocWith PageMode $ d stl renderMsg d stl = Pretty.showDocWith PageMode $ d stl
#endif #endif
@ -109,15 +109,15 @@ fOptions = [option | (option,_,_) <- fFlags]
---------------------------------------------------------------- ----------------------------------------------------------------
setCtx :: [ModSummary] -> Ghc Bool setCtx :: [ModSummary] -> Ghc Bool
#if __GLASGOW_HASKELL__ >= 704 #if __GLASGOW_HASKELL__ >= 70
setCtx ms = do setCtx ms = do
top <- map (IIModule . ms_mod) <$> filterM isTop ms top <- map (IIModule . moduleName . ms_mod) <$> filterM isTop ms
setContext top setContext top
return (not . null $ top) return (not . null $ top)
#else #else
setCtx ms = do setCtx ms = do
top <- map ms_mod <$> filterM isTop ms top <- map (IIModule . ms_mod) <$> filterM isTop ms
setContext top [] setContext top
return (not . null $ top) return (not . null $ top)
#endif #endif
where where

7
Info.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances, RankNTypes #-}
module Info (infoExpr, typeExpr) where module Info (infoExpr, typeExpr) where
@ -10,6 +10,7 @@ import Data.Generics
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Ord as O import Data.Ord as O
import DynFlags (tracingDynFlags)
import Desugar import Desugar
import GHC import GHC
import GHC.SYB.Utils 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])) listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
pretty :: Type -> String 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 -- from ghc/InteractiveUI.hs
@ -125,7 +126,7 @@ filterOutChildren get_thing xs
where where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] 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) pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing = pprTyThingInContextLoc pefas thing
$$ show_fixity fixity $$ show_fixity fixity