hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Language/Haskell/GhcMod/Browse.hs
View File

@ -12,7 +12,7 @@ import Data.Maybe (catMaybes)
import FastString (mkFastString) import FastString (mkFastString)
import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module) import GHC (Ghc, GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module)
import qualified GHC as G 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.GHCApi
import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
@ -130,7 +130,7 @@ removeForAlls' ty (Just (pre, ftype))
| otherwise = ty | otherwise = ty
showOutputable :: Outputable a => DynFlags -> a -> String 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 where
mdl = G.moduleNameString (G.moduleName m) mdl = G.moduleNameString (G.moduleName m)
names = G.modInfoExports inf names = G.modInfoExports inf
toStr = showUnqualifiedOneLine dflag . ppr toStr = showOneLine dflag styleUnqualified . ppr

43
Language/Haskell/GhcMod/Doc.hs
View File

@ -1,43 +1,22 @@
module Language.Haskell.GhcMod.Doc where module Language.Haskell.GhcMod.Doc where
import DynFlags (DynFlags) import DynFlags (DynFlags)
import GHC (Ghc)
import qualified GHC as G
import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) 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(..)) import Pretty (Mode(..))
---------------------------------------------------------------- showPage :: DynFlags -> PprStyle -> SDoc -> String
showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
{- showOneLine :: DynFlags -> PprStyle -> SDoc -> String
pretty :: Outputable a => a -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
pretty = showSDocForUser neverQualify . ppr
debug :: Outputable a => a -> b -> b getStyle :: Ghc PprStyle
debug x v = trace (pretty x) v getStyle = do
-} unqual <- G.getPrintUnqual
return $ mkUserStyle unqual AllTheWay
----------------------------------------------------------------
styleQualified :: PprStyle
styleQualified = mkUserStyle alwaysQualify AllTheWay
styleUnqualified :: PprStyle styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay 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

33
Language/Haskell/GhcMod/ErrMsg.hs
View File

@ -15,10 +15,10 @@ import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError)) import GHC (Ghc, DynFlags, SrcSpan, Severity(SevError))
import qualified GHC as G import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages) 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 qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types (LineSeparator(..)) import Language.Haskell.GhcMod.Types (LineSeparator(..))
import Outputable (SDoc) import Outputable (PprStyle, SDoc)
import System.FilePath (normalise) import System.FilePath (normalise)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -41,9 +41,9 @@ readAndClearLogRef (LogRef ref) = do
writeIORef ref id writeIORef ref id
return $! b [] return $! b []
appendLogRef :: DynFlags -> LineSeparator -> LogRef -> a -> Severity -> SrcSpan -> b -> SDoc -> IO () appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df ls (LogRef ref) _ sev src _ msg = do appendLogRef df ls (LogRef ref) _ sev src style msg = do
let !l = ppMsg src sev df ls msg let !l = ppMsg src sev df ls style msg
modifyIORef ref (\b -> b . (l:)) modifyIORef ref (\b -> b . (l:))
---------------------------------------------------------------- ----------------------------------------------------------------
@ -63,24 +63,25 @@ setLogger True df ls = do
handleErrMsg :: LineSeparator -> SourceError -> Ghc [String] handleErrMsg :: LineSeparator -> SourceError -> Ghc [String]
handleErrMsg ls err = do handleErrMsg ls err = do
dflag <- G.getSessionDynFlags 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 :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList
---------------------------------------------------------------- ----------------------------------------------------------------
ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String ppErrMsg :: DynFlags -> LineSeparator -> PprStyle -> ErrMsg -> String
ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext ppErrMsg dflag ls style err = ppMsg spn SevError dflag ls style msg ++ ext
where where
spn = Gap.errorMsgSpan err spn = Gap.errorMsgSpan err
msg = errMsgShortDoc 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 :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> PprStyle -> SDoc -> String
ppMsg spn sev dflag ls msg = prefix ++ cts ppMsg spn sev dflag ls style msg = prefix ++ cts
where where
cts = showMsg dflag ls msg cts = showMsg dflag ls style msg
defaultPrefix defaultPrefix
| dopt Gap.dumpSplicesFlag dflag = "" | dopt Gap.dumpSplicesFlag dflag = ""
| otherwise = "Dummy:0:0:Error:" | otherwise = "Dummy:0:0:Error:"
@ -92,8 +93,8 @@ ppMsg spn sev dflag ls msg = prefix ++ cts
---------------------------------------------------------------- ----------------------------------------------------------------
showMsg :: DynFlags -> LineSeparator -> SDoc -> String showMsg :: DynFlags -> LineSeparator -> PprStyle -> SDoc -> String
showMsg dflag (LineSeparator lsep) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc showMsg dflag (LineSeparator lsep) style sdoc = replaceNull $ showPage dflag style sdoc
where where
replaceNull [] = [] replaceNull [] = []
replaceNull ('\n':xs) = lsep ++ replaceNull xs replaceNull ('\n':xs) = lsep ++ replaceNull xs

21
Language/Haskell/GhcMod/Info.hs
View File

@ -24,13 +24,13 @@ import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, Sr
import qualified GHC as G import qualified GHC as G
import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged) import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
import HscTypes (ms_imps) 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.GHCApi
import Language.Haskell.GhcMod.GHCChoice ((||>), goNext) import Language.Haskell.GhcMod.GHCChoice ((||>), goNext)
import Language.Haskell.GhcMod.Gap (HasType(..)) import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Outputable (ppr) import Outputable (PprStyle, ppr)
import TcHsSyn (hsPatType) import TcHsSyn (hsPatType)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -61,7 +61,8 @@ info opt cradle file modstr expr =
exprToInfo = do exprToInfo = do
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
sdoc <- Gap.infoThing expr 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 ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps pts <- mapM (getType tcm) ps
dflag <- G.getSessionDynFlags 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 return $ convert opt sss
toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
toTup dflag (spn, typ) = (fourInts spn, pretty dflag typ) toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)
fourInts :: SrcSpan -> (Int,Int,Int,Int) fourInts :: SrcSpan -> (Int,Int,Int,Int)
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan 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 :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
pretty :: DynFlags -> Type -> String pretty :: DynFlags -> PprStyle -> Type -> String
pretty dflag = showUnqualifiedOneLine dflag . Gap.typeForUser pretty dflag style = showOneLine dflag style . Gap.typeForUser
---------------------------------------------------------------- ----------------------------------------------------------------
@ -154,7 +156,8 @@ inModuleContext _ opt cradle file modstr action errmsg =
setTargetBuffer = do setTargetBuffer = do
modgraph <- G.depanal [G.mkModuleName modstr] True modgraph <- G.depanal [G.mkModuleName modstr] True
dflag <- G.getSessionDynFlags 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 map ms_imps modgraph ++ map G.ms_srcimps modgraph
moddef = "module " ++ sanitize modstr ++ " where" moddef = "module " ++ sanitize modstr ++ " where"
header = moddef : imports header = moddef : imports