hdevtools 0.1.0.2 → 0.1.0.3
raw patch · 3 files changed
+82/−9 lines, 3 filesdep −ghc-syb-utils
Dependencies removed: ghc-syb-utils
Files
- hdevtools.cabal +1/−2
- src/CommandLoop.hs +14/−3
- src/Info.hs +67/−4
hdevtools.cabal view
@@ -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,
src/CommandLoop.hs view
@@ -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
src/Info.hs view
@@ -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<TypeChecker) :: GHC.PostTcType -> Bool+ fixity = const (stage<Renamer) :: GHC.Fixity -> 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