Replace redirected filenames in info.

Language/Haskell/GhcMod/Gap.hs

@@ -67,6 +67,7 @@ import TcType
 import Var (varType)
 import System.Directory
 
+import qualified Name
 import qualified InstEnv
 import qualified Pretty
 import qualified StringBuffer as SB
@@ -328,8 +329,8 @@ filterOutChildren get_thing xs
   where
     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 
-infoThing :: GhcMonad m => Expression -> m SDoc
+infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
-infoThing (Expression str) = do
+infoThing m (Expression str) = do
     names <- parseName str
 #if __GLASGOW_HASKELL__ >= 708
     mb_stuffs <- mapM (getInfo False) names
@@ -338,30 +339,45 @@ infoThing (Expression str) = do
     mb_stuffs <- mapM getInfo names
     let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
 #endif
-    return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
+    return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)
 
 #if __GLASGOW_HASKELL__ >= 708
-pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
+pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
-pprInfo _ (thing, fixity, insts, famInsts)
+pprInfo m _ (thing, fixity, insts, famInsts)
-    = pprTyThingInContextLoc thing
+    = pprTyThingInContextLoc' thing
    $$ show_fixity fixity
    $$ InstEnv.pprInstances insts
    $$ pprFamInsts famInsts
-  where
-    show_fixity fx
-      | fx == defaultFixity = Outputable.empty
-      | otherwise           = ppr fx <+> ppr (getName thing)
 #else
-pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
+pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
-pprInfo pefas (thing, fixity, insts)
+pprInfo m pefas (thing, fixity, insts)
-    = pprTyThingInContextLoc pefas thing
+    = pprTyThingInContextLoc' pefas thing
    $$ show_fixity fixity
    $$ vcat (map pprInstance insts)
+#endif
   where
     show_fixity fx
       | fx == defaultFixity = Outputable.empty
       | otherwise           = ppr fx <+> ppr (getName thing)
+#if __GLASGOW_HASKELL__ >= 708
+    pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2
+                                        (char '\t' <> ptext (sLit "--") <+> loc)
+                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+#else
+    pprTyThingInContextLoc' pefas thing' = hang (pprTyThingInContext pefas thing') 2
+                                    (char '\t' <> ptext (sLit "--") <+> loc)
+                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
 #endif
+    pprNameDefnLoc' name
+      = case Name.nameSrcLoc name of
+           RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
+           UnhelpfulLoc s
+             | Name.isInternalName name || Name.isSystemName name
+             -> ptext (sLit "at") <+> ftext s
+             | otherwise
+             -> ptext (sLit "in") <+> quotes (ppr (nameModule name))
+      where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)
+            realFP = mkFastString . m . unpackFS . srcLocFile
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Info.hs

@@ -22,6 +22,7 @@ import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
 
 ----------------------------------------------------------------
@@ -41,9 +42,10 @@ info file expr =
       gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
       convert' "Cannot show info"
 
-    body :: GhcMonad m => m String
+    body :: (GhcMonad m, GmState m, GmEnv m) => m String
     body = do
-      sdoc  <- Gap.infoThing expr
+      m <- mkRevRedirMapFunc
+      sdoc  <- Gap.infoThing m expr
       st    <- getStyle
       dflag <- G.getSessionDynFlags
       return $ showPage dflag st sdoc

Language/Haskell/GhcMod/Logger.hs

@@ -9,11 +9,10 @@ module Language.Haskell.GhcMod.Logger (
 import Control.Arrow
 import Control.Applicative
 import Data.List (isPrefixOf)
-import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
-import Data.Maybe (fromMaybe, mapMaybe)
 import Control.Monad.Reader (Reader, asks, runReader)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
-import System.FilePath (normalise, makeRelative)
+import System.FilePath (normalise)
 import Text.PrettyPrint
 
 import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
@@ -28,7 +27,7 @@ import Language.Haskell.GhcMod.Doc (showPage)
 import Language.Haskell.GhcMod.DynFlags (withDynFlags)
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Error
-import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Prelude
 
@@ -87,16 +86,7 @@ withLogger' :: (IOish m, GmState m, GmEnv m)
 withLogger' env action = do
     logref <- liftIO $ newLogRef
 
-    rfm <- do
+    rfm <- mkRevRedirMapFunc
-      mm <- Map.toList <$> getMMappedFiles
-      let
-          mf :: FilePath -> FileMapping -> Maybe (FilePath, FilePath)
-          mf from (RedirectedMapping to)
-                 = Just (to, from)
-          mf _ _ = Nothing
-      return $ Map.fromList $ mapMaybe (uncurry mf) mm
-
-    crdl <- cradle
 
     let dflags = hsc_dflags env
         pu = icPrintUnqual dflags (hsc_IC env)
@@ -104,10 +94,7 @@ withLogger' env action = do
         st = GmPprEnv {
                 rsDynFlags = dflags
               , rsPprStyle = stl
-              , rsMapFile = \key ->
+              , rsMapFile = rfm
-                              fromMaybe key
-                              $ makeRelative (cradleRootDir crdl)
-                              <$> Map.lookup key rfm
         }
 
         setLogger df = Gap.setLogAction df $ appendLogRef st df logref

Language/Haskell/GhcMod/Utils.hs

@@ -25,6 +25,8 @@ module Language.Haskell.GhcMod.Utils (
 
 import Control.Applicative
 import Data.Char
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe, fromMaybe)
 import Exception
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Types
@@ -33,7 +35,7 @@ import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist
                          getTemporaryDirectory, canonicalizePath, removeFile)
 import System.Environment
 import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
-                        (</>))
+                        (</>), makeRelative)
 import System.IO.Temp (createTempDirectory, openTempFile)
 import System.IO (hPutStr, hClose)
 import System.Process (readProcess)
@@ -183,3 +185,17 @@ getCanonicalFileNameSafe fn = do
   if fex
     then liftIO $ canonicalizePath ccfn
     else return ccfn
+
+mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
+mkRevRedirMapFunc = do
+  rm <- M.fromList <$> mapMaybe (uncurry mf) <$> M.toList <$> getMMappedFiles
+  crdl <- cradle
+  return $ \key ->
+    fromMaybe key
+    $ makeRelative (cradleRootDir crdl)
+    <$> M.lookup key rm
+  where
+    mf :: FilePath -> FileMapping -> Maybe (FilePath, FilePath)
+    mf from (RedirectedMapping to)
+           = Just (to, from)
+    mf _ _ = Nothing