From a6579c656beff94f34d2e9224ac3ea52f54a814e Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 3 Apr 2014 09:49:23 +0900 Subject: [PATCH] Displaying a qualified name if two unqualified names are conflict (#130). --- Language/Haskell/GhcMod/Browse.hs | 6 ++--- Language/Haskell/GhcMod/Doc.hs | 43 ++++++++----------------------- Language/Haskell/GhcMod/ErrMsg.hs | 33 ++++++++++++------------ Language/Haskell/GhcMod/Info.hs | 21 ++++++++------- 4 files changed, 43 insertions(+), 60 deletions(-) diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 7e12e18..1053c75 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -12,7 +12,7 @@ import Data.Maybe (catMaybes) import FastString (mkFastString) import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module) import qualified GHC as G -import Language.Haskell.GhcMod.Doc (showUnqualifiedPage, showUnqualifiedOneLine) +import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Types @@ -130,7 +130,7 @@ removeForAlls' ty (Just (pre, ftype)) | otherwise = ty showOutputable :: Outputable a => DynFlags -> a -> String -showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr +showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr ---------------------------------------------------------------- @@ -147,4 +147,4 @@ toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names where mdl = G.moduleNameString (G.moduleName m) names = G.modInfoExports inf - toStr = showUnqualifiedOneLine dflag . ppr + toStr = showOneLine dflag styleUnqualified . ppr diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs index 7de49c1..e99c2d0 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -1,43 +1,22 @@ module Language.Haskell.GhcMod.Doc where import DynFlags (DynFlags) +import GHC (Ghc) +import qualified GHC as G import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) -import Outputable (SDoc, PprStyle, Depth(AllTheWay), mkUserStyle, alwaysQualify, neverQualify) +import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify) import Pretty (Mode(..)) ----------------------------------------------------------------- +showPage :: DynFlags -> PprStyle -> SDoc -> String +showPage dflag style = showDocWith dflag PageMode . withStyle dflag style -{- -pretty :: Outputable a => a -> String -pretty = showSDocForUser neverQualify . ppr +showOneLine :: DynFlags -> PprStyle -> SDoc -> String +showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style -debug :: Outputable a => a -> b -> b -debug x v = trace (pretty x) v --} - ----------------------------------------------------------------- - -styleQualified :: PprStyle -styleQualified = mkUserStyle alwaysQualify AllTheWay +getStyle :: Ghc PprStyle +getStyle = do + unqual <- G.getPrintUnqual + return $ mkUserStyle unqual AllTheWay styleUnqualified :: PprStyle styleUnqualified = mkUserStyle neverQualify AllTheWay - ----------------------------------------------------------------- - --- For "ghc-mod type" -showQualifiedPage :: DynFlags -> SDoc -> String -showQualifiedPage dflag = showDocWith dflag PageMode . withStyle dflag styleQualified - --- For "ghc-mod browse" and show GHC's error messages. -showUnqualifiedPage :: DynFlags -> SDoc -> String -showUnqualifiedPage dflag = showDocWith dflag PageMode - . withStyle dflag styleUnqualified - --- Not used -showQualifiedOneLine :: DynFlags -> SDoc -> String -showQualifiedOneLine dflag = showDocWith dflag OneLineMode . withStyle dflag styleQualified - --- To write Haskell code in a buffer -showUnqualifiedOneLine :: DynFlags -> SDoc -> String -showUnqualifiedOneLine dflag = showDocWith dflag OneLineMode . withStyle dflag styleUnqualified diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs index 6ebb90a..06712b5 100644 --- a/Language/Haskell/GhcMod/ErrMsg.hs +++ b/Language/Haskell/GhcMod/ErrMsg.hs @@ -15,10 +15,10 @@ import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError)) import qualified GHC as G import HscTypes (SourceError, srcErrorMessages) -import Language.Haskell.GhcMod.Doc (showUnqualifiedPage) +import Language.Haskell.GhcMod.Doc (showPage, getStyle) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types (LineSeparator(..)) -import Outputable (SDoc) +import Outputable (PprStyle, SDoc) import System.FilePath (normalise) ---------------------------------------------------------------- @@ -41,9 +41,9 @@ readAndClearLogRef (LogRef ref) = do writeIORef ref id return $! b [] -appendLogRef :: DynFlags -> LineSeparator -> LogRef -> a -> Severity -> SrcSpan -> b -> SDoc -> IO () -appendLogRef df ls (LogRef ref) _ sev src _ msg = do - let !l = ppMsg src sev df ls msg +appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () +appendLogRef df ls (LogRef ref) _ sev src style msg = do + let !l = ppMsg src sev df ls style msg modifyIORef ref (\b -> b . (l:)) ---------------------------------------------------------------- @@ -63,24 +63,25 @@ setLogger True df ls = do handleErrMsg :: LineSeparator -> SourceError -> Ghc [String] handleErrMsg ls err = do dflag <- G.getSessionDynFlags - return . errBagToStrList dflag ls . srcErrorMessages $ err + style <- getStyle + return . errBagToStrList dflag ls style . srcErrorMessages $ err -errBagToStrList :: DynFlags -> LineSeparator -> Bag ErrMsg -> [String] -errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList +errBagToStrList :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String] +errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList ---------------------------------------------------------------- -ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String -ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext +ppErrMsg :: DynFlags -> LineSeparator -> PprStyle -> ErrMsg -> String +ppErrMsg dflag ls style err = ppMsg spn SevError dflag ls style msg ++ ext where spn = Gap.errorMsgSpan err msg = errMsgShortDoc err - ext = showMsg dflag ls (errMsgExtraInfo err) + ext = showMsg dflag ls style (errMsgExtraInfo err) -ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> SDoc -> String -ppMsg spn sev dflag ls msg = prefix ++ cts +ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> PprStyle -> SDoc -> String +ppMsg spn sev dflag ls style msg = prefix ++ cts where - cts = showMsg dflag ls msg + cts = showMsg dflag ls style msg defaultPrefix | dopt Gap.dumpSplicesFlag dflag = "" | otherwise = "Dummy:0:0:Error:" @@ -92,8 +93,8 @@ ppMsg spn sev dflag ls msg = prefix ++ cts ---------------------------------------------------------------- -showMsg :: DynFlags -> LineSeparator -> SDoc -> String -showMsg dflag (LineSeparator lsep) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc +showMsg :: DynFlags -> LineSeparator -> PprStyle -> SDoc -> String +showMsg dflag (LineSeparator lsep) style sdoc = replaceNull $ showPage dflag style sdoc where replaceNull [] = [] replaceNull ('\n':xs) = lsep ++ replaceNull xs diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 70257f7..c94ce19 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -24,13 +24,13 @@ import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, Sr import qualified GHC as G import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged) import HscTypes (ms_imps) -import Language.Haskell.GhcMod.Doc (showUnqualifiedPage, showUnqualifiedOneLine, showQualifiedPage) +import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCChoice ((||>), goNext) import Language.Haskell.GhcMod.Gap (HasType(..)) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types -import Outputable (ppr) +import Outputable (PprStyle, ppr) import TcHsSyn (hsPatType) ---------------------------------------------------------------- @@ -61,7 +61,8 @@ info opt cradle file modstr expr = exprToInfo = do dflag <- G.getSessionDynFlags sdoc <- Gap.infoThing expr - return $ showUnqualifiedPage dflag sdoc + style <- getStyle + return $ showPage dflag style sdoc ---------------------------------------------------------------- @@ -108,11 +109,12 @@ typeOf opt cradle file modstr lineNo colNo = ets <- mapM (getType tcm) es pts <- mapM (getType tcm) ps dflag <- G.getSessionDynFlags - let sss = map (toTup dflag) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts] + style <- getStyle + let sss = map (toTup dflag style) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts] return $ convert opt sss - toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) - toTup dflag (spn, typ) = (fourInts spn, pretty dflag typ) + toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) + toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) fourInts :: SrcSpan -> (Int,Int,Int,Int) fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan @@ -132,8 +134,8 @@ listifySpans tcs lc = listifyStaged TypeChecker p tcs listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) -pretty :: DynFlags -> Type -> String -pretty dflag = showUnqualifiedOneLine dflag . Gap.typeForUser +pretty :: DynFlags -> PprStyle -> Type -> String +pretty dflag style = showOneLine dflag style . Gap.typeForUser ---------------------------------------------------------------- @@ -154,7 +156,8 @@ inModuleContext _ opt cradle file modstr action errmsg = setTargetBuffer = do modgraph <- G.depanal [G.mkModuleName modstr] True dflag <- G.getSessionDynFlags - let imports = concatMap (map (showQualifiedPage dflag . ppr . G.unLoc)) $ + style <- getStyle + let imports = concatMap (map (showPage dflag style . ppr . G.unLoc)) $ map ms_imps modgraph ++ map G.ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports