diff --git a/hdevtools.cabal b/hdevtools.cabal --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -1,5 +1,5 @@ name: hdevtools -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Persistent GHC powered background server for FAST haskell development tools -- description: license: MIT @@ -37,7 +37,6 @@ directory, ghc, ghc-paths, - ghc-syb-utils, syb, network, time, diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE CPP #-} module CommandLoop ( startCommandLoop ) where -import ErrUtils (Message, mkLocMessage) +import qualified ErrUtils import GHC (Ghc, GhcException, GhcLink(NoLink), HscTarget(HscInterpreted), LoadHowMuch(LoadAllTargets), Severity, SrcSpan, SuccessFlag(Succeeded, Failed), gcatch, getSessionDynFlags, ghcLink, guessTarget, handleSourceError, hscTarget, load, log_action, noLoc, parseDynamicFlags, printException, runGhc, setSessionDynFlags, setTargets, showGhcException) +import qualified GHC import GHC.Paths (libdir) import MonadUtils (MonadIO, liftIO) import Outputable (PprStyle, renderWithStyle) @@ -116,9 +118,18 @@ , "\"", t, "\"" ] -logAction :: ClientSend -> Severity -> SrcSpan -> PprStyle -> Message -> IO () +#if __GLASGOW_HASKELL__ >= 706 +logAction :: ClientSend -> GHC.DynFlags -> Severity -> SrcSpan -> PprStyle -> ErrUtils.MsgDoc -> IO () +logAction clientSend dflags severity srcspan style msg = + let out = renderWithStyle dflags fullMsg style + _ = severity + in clientSend (ClientStdout out) + where fullMsg = ErrUtils.mkLocMessage severity srcspan msg +#else +logAction :: ClientSend -> Severity -> SrcSpan -> PprStyle -> ErrUtils.Message -> IO () logAction clientSend severity srcspan style msg = let out = renderWithStyle fullMsg style _ = severity in clientSend (ClientStdout out) - where fullMsg = mkLocMessage srcspan msg + where fullMsg = ErrUtils.mkLocMessage srcspan msg +#endif diff --git a/src/Info.hs b/src/Info.hs --- a/src/Info.hs +++ b/src/Info.hs @@ -1,17 +1,19 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} module Info ( getIdentifierInfo , getType ) where import Control.Monad (liftM) -import Data.Generics (GenericQ, mkQ) +import Data.Generics (GenericQ, mkQ, extQ, gmapQ) import Data.List (find, sortBy, intersperse) import Data.Maybe (catMaybes, fromMaybe) import Data.Typeable (Typeable) -import GHC.SYB.Utils (everythingStaged, Stage(TypeChecker)) import MonadUtils (liftIO) import qualified CoreUtils import qualified Desugar +import qualified DynFlags import qualified GHC import qualified HscTypes import qualified NameSet @@ -24,7 +26,13 @@ getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String) getIdentifierInfo file identifier = withModSummary file $ \m -> do +#if __GLASGOW_HASKELL__ >= 706 + GHC.setContext [GHC.IIModule (GHC.moduleName (GHC.ms_mod m))] +#elif __GLASGOW_HASKELL__ >= 704 GHC.setContext [GHC.IIModule (GHC.ms_mod m)] +#else + GHC.setContext [GHC.ms_mod m] [] +#endif GHC.handleSourceError (return . Left . show) $ liftM Right (infoThing identifier) @@ -84,15 +92,26 @@ bts <- mapM (getTypeLHsBind tcm) bs ets <- mapM (getTypeLHsExpr tcm) es pts <- mapM (getTypeLPat tcm) ps - return $ map toTup $ sortBy cmp $ catMaybes $ concat [ets, bts, pts] +#if __GLASGOW_HASKELL__ >= 706 + dflags <- DynFlags.getDynFlags + return $ map (toTup dflags) $ +#else + return $ map toTup $ +#endif + sortBy cmp $ catMaybes $ concat [ets, bts, pts] where cmp (a, _) (b, _) | a `GHC.isSubspanOf` b = LT | b `GHC.isSubspanOf` a = GT | otherwise = EQ +#if __GLASGOW_HASKELL__ >= 706 +toTup :: GHC.DynFlags -> (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) +toTup dflags (spn, typ) = (fourInts spn, pretty dflags typ) +#else toTup :: (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String) toTup (spn, typ) = (fourInts spn, pretty typ) +#endif fourInts :: GHC.SrcSpan -> (Int, Int, Int, Int) fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan @@ -133,13 +152,44 @@ listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) +#if __GLASGOW_HASKELL__ >= 706 +pretty :: GHC.DynFlags -> GHC.Type -> String +pretty dflags = +#else pretty :: GHC.Type -> String pretty = +#endif Pretty.showDocWith Pretty.OneLineMode - . Outputable.withPprStyleDoc (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) +#if __GLASGOW_HASKELL__ >= 706 + . Outputable.withPprStyleDoc dflags +#else + . Outputable.withPprStyleDoc +#endif + (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) . PprTyThing.pprTypeForUser False ------------------------------------------------------------------------------ +-- The following was taken from 'ghc-syb-utils' +-- +-- ghc-syb-utils: +-- https://github.com/nominolo/ghc-syb + +-- | Ghc Ast types tend to have undefined holes, to be filled +-- by later compiler phases. We tag Asts with their source, +-- so that we can avoid such holes based on who generated the Asts. +data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show) + +-- | Like 'everything', but avoid known potholes, based on the 'Stage' that +-- generated the Ast. +everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r +everythingStaged stage k z f x + | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z + | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) + where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet.NameSet -> Bool + postTcType = const (stage Bool + fixity = const (stage Bool + +------------------------------------------------------------------------------ -- The following code was taken from GHC's ghc/InteractiveUI.hs (with some -- stylistic changes) @@ -149,7 +199,12 @@ mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual +#if __GLASGOW_HASKELL__ >= 706 + dflags <- DynFlags.getDynFlags + return $ Outputable.showSDocForUser dflags unqual $ +#else return $ Outputable.showSDocForUser unqual $ +#endif Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) -- Filter out names whose parent is also there Good @@ -160,11 +215,19 @@ = filter (not . has_parent) xs where all_names = NameSet.mkNameSet (map (GHC.getName . get_thing) xs) +#if __GLASGOW_HASKELL__ >= 704 has_parent x = case HscTypes.tyThingParent_maybe (get_thing x) of +#else + has_parent x = case PprTyThing.pprTyThingParent_maybe (get_thing x) of +#endif Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False +#if __GLASGOW_HASKELL__ >= 706 +pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc +#else pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc +#endif pprInfo pefas (thing, fixity, insts) = PprTyThing.pprTyThingInContextLoc pefas thing Outputable.$$ show_fixity fixity