Displaying a qualified name if two unqualified names are conflict (#130).

This commit is contained in:
Kazu Yamamoto 2014-04-03 09:49:23 +09:00
parent ef266374c0
commit a6579c656b
4 changed files with 43 additions and 60 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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