Displaying a qualified name if two unqualified names are conflict (#130).
This commit is contained in:
Kazu Yamamoto
parent
ef266374c0
commit
a6579c656b
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue