GHC 7.6.1 compatibility
- switch from ClockTime to UTCTime in Info.pprInfo - make ghc-mod loggers always take a first argument of type DynFlags - consolidate GHC API shims in Gap.hs--this depends on tracingDynFlags, which is unfortunate
This commit is contained in:
ihameed
parent
594590f539
commit
8e335fbc3b
2
Check.hs
2
Check.hs
@ -7,7 +7,7 @@ import ErrMsg
|
||||
import Exception
|
||||
import GHC
|
||||
import GHCApi
|
||||
import Prelude hiding (catch)
|
||||
import Prelude
|
||||
import Types
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
89
Gap.hs
89
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
|
||||
|
||||
17
Info.hs
17
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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user