diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index c8b6e0fa9..007976c75 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/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 (Expression str) = do +infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc +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 _ (thing, fixity, insts, famInsts) - = pprTyThingInContextLoc thing +pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc +pprInfo m _ (thing, fixity, insts, famInsts) + = 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 pefas (thing, fixity, insts) - = pprTyThingInContextLoc pefas thing +pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc +pprInfo m pefas (thing, fixity, insts) + = 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) -#endif +#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 ---------------------------------------------------------------- ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 23e595058..f22451dd7 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index c6c1598a3..1d3f38ae8 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/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, mapMaybe) +import Data.Maybe (fromMaybe) 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 - 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 + rfm <- mkRevRedirMapFunc 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 -> - fromMaybe key - $ makeRelative (cradleRootDir crdl) - <$> Map.lookup key rfm + , rsMapFile = rfm } setLogger df = Gap.setLogAction df $ appendLogRef st df logref diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 73d2fed8e..c4f2710ca 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/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