Replace redirected filenames in info.
This commit is contained in:
parent
c2ff5be4ea
commit
e7329a9d24
@ -67,6 +67,7 @@ import TcType
|
|||||||
import Var (varType)
|
import Var (varType)
|
||||||
import System.Directory
|
import System.Directory
|
||||||
|
|
||||||
|
import qualified Name
|
||||||
import qualified InstEnv
|
import qualified InstEnv
|
||||||
import qualified Pretty
|
import qualified Pretty
|
||||||
import qualified StringBuffer as SB
|
import qualified StringBuffer as SB
|
||||||
@ -328,8 +329,8 @@ filterOutChildren get_thing xs
|
|||||||
where
|
where
|
||||||
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
|
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
|
names <- parseName str
|
||||||
#if __GLASGOW_HASKELL__ >= 708
|
#if __GLASGOW_HASKELL__ >= 708
|
||||||
mb_stuffs <- mapM (getInfo False) names
|
mb_stuffs <- mapM (getInfo False) names
|
||||||
@ -338,30 +339,45 @@ infoThing (Expression str) = do
|
|||||||
mb_stuffs <- mapM getInfo names
|
mb_stuffs <- mapM getInfo names
|
||||||
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
|
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
|
||||||
#endif
|
#endif
|
||||||
return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
|
return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)
|
||||||
|
|
||||||
#if __GLASGOW_HASKELL__ >= 708
|
#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
|
$$ show_fixity fixity
|
||||||
$$ InstEnv.pprInstances insts
|
$$ InstEnv.pprInstances insts
|
||||||
$$ pprFamInsts famInsts
|
$$ pprFamInsts famInsts
|
||||||
where
|
|
||||||
show_fixity fx
|
|
||||||
| fx == defaultFixity = Outputable.empty
|
|
||||||
| otherwise = ppr fx <+> ppr (getName thing)
|
|
||||||
#else
|
#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
|
$$ show_fixity fixity
|
||||||
$$ vcat (map pprInstance insts)
|
$$ vcat (map pprInstance insts)
|
||||||
|
#endif
|
||||||
where
|
where
|
||||||
show_fixity fx
|
show_fixity fx
|
||||||
| fx == defaultFixity = Outputable.empty
|
| fx == defaultFixity = Outputable.empty
|
||||||
| otherwise = ppr fx <+> ppr (getName thing)
|
| 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
|
#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
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
@ -22,6 +22,7 @@ import Language.Haskell.GhcMod.Logging
|
|||||||
import Language.Haskell.GhcMod.Monad
|
import Language.Haskell.GhcMod.Monad
|
||||||
import Language.Haskell.GhcMod.SrcUtils
|
import Language.Haskell.GhcMod.SrcUtils
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
|
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
|
||||||
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
|
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
@ -41,9 +42,10 @@ info file expr =
|
|||||||
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
|
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
|
||||||
convert' "Cannot show info"
|
convert' "Cannot show info"
|
||||||
|
|
||||||
body :: GhcMonad m => m String
|
body :: (GhcMonad m, GmState m, GmEnv m) => m String
|
||||||
body = do
|
body = do
|
||||||
sdoc <- Gap.infoThing expr
|
m <- mkRevRedirMapFunc
|
||||||
|
sdoc <- Gap.infoThing m expr
|
||||||
st <- getStyle
|
st <- getStyle
|
||||||
dflag <- G.getSessionDynFlags
|
dflag <- G.getSessionDynFlags
|
||||||
return $ showPage dflag st sdoc
|
return $ showPage dflag st sdoc
|
||||||
|
@ -9,11 +9,10 @@ module Language.Haskell.GhcMod.Logger (
|
|||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.List (isPrefixOf)
|
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 Control.Monad.Reader (Reader, asks, runReader)
|
||||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
||||||
import System.FilePath (normalise, makeRelative)
|
import System.FilePath (normalise)
|
||||||
import Text.PrettyPrint
|
import Text.PrettyPrint
|
||||||
|
|
||||||
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
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.DynFlags (withDynFlags)
|
||||||
import Language.Haskell.GhcMod.Monad.Types
|
import Language.Haskell.GhcMod.Monad.Types
|
||||||
import Language.Haskell.GhcMod.Error
|
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 qualified Language.Haskell.GhcMod.Gap as Gap
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
@ -87,16 +86,7 @@ withLogger' :: (IOish m, GmState m, GmEnv m)
|
|||||||
withLogger' env action = do
|
withLogger' env action = do
|
||||||
logref <- liftIO $ newLogRef
|
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
|
let dflags = hsc_dflags env
|
||||||
pu = icPrintUnqual dflags (hsc_IC env)
|
pu = icPrintUnqual dflags (hsc_IC env)
|
||||||
@ -104,10 +94,7 @@ withLogger' env action = do
|
|||||||
st = GmPprEnv {
|
st = GmPprEnv {
|
||||||
rsDynFlags = dflags
|
rsDynFlags = dflags
|
||||||
, rsPprStyle = stl
|
, rsPprStyle = stl
|
||||||
, rsMapFile = \key ->
|
, rsMapFile = rfm
|
||||||
fromMaybe key
|
|
||||||
$ makeRelative (cradleRootDir crdl)
|
|
||||||
<$> Map.lookup key rfm
|
|
||||||
}
|
}
|
||||||
|
|
||||||
setLogger df = Gap.setLogAction df $ appendLogRef st df logref
|
setLogger df = Gap.setLogAction df $ appendLogRef st df logref
|
||||||
|
@ -25,6 +25,8 @@ module Language.Haskell.GhcMod.Utils (
|
|||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import Data.Maybe (mapMaybe, fromMaybe)
|
||||||
import Exception
|
import Exception
|
||||||
import Language.Haskell.GhcMod.Error
|
import Language.Haskell.GhcMod.Error
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
@ -33,7 +35,7 @@ import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist
|
|||||||
getTemporaryDirectory, canonicalizePath, removeFile)
|
getTemporaryDirectory, canonicalizePath, removeFile)
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
||||||
(</>))
|
(</>), makeRelative)
|
||||||
import System.IO.Temp (createTempDirectory, openTempFile)
|
import System.IO.Temp (createTempDirectory, openTempFile)
|
||||||
import System.IO (hPutStr, hClose)
|
import System.IO (hPutStr, hClose)
|
||||||
import System.Process (readProcess)
|
import System.Process (readProcess)
|
||||||
@ -183,3 +185,17 @@ getCanonicalFileNameSafe fn = do
|
|||||||
if fex
|
if fex
|
||||||
then liftIO $ canonicalizePath ccfn
|
then liftIO $ canonicalizePath ccfn
|
||||||
else return 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
|
||||||
|
Loading…
Reference in New Issue
Block a user