file map line pragmas

.gitignore

@@ -4,6 +4,7 @@ elisp/*.elc
 /.cabal-sandbox/
 /.stack-work/
 /test/data/**/stack.yaml
+/test/data/**/.cabal-sandbox/
 add-source-timestamps
 package.cache
 cabal.sandbox.config

GhcMod/Exe/Info.hs

@@ -20,7 +20,6 @@ import GhcMod.Logging
 import GhcMod.Monad
 import GhcMod.SrcUtils
 import GhcMod.Types
-import GhcMod.Utils (mkRevRedirMapFunc)
 import GhcMod.FileMapping (fileModSummaryWithMapping)
 
 ----------------------------------------------------------------
@@ -42,8 +41,7 @@ info file expr =
 
     body :: (GhcMonad m, GmState m, GmEnv m) => m String
     body = do
-      m <- mkRevRedirMapFunc
-      sdoc  <- Gap.infoThing m expr
+      sdoc  <- Gap.infoThing expr
       st    <- getStyle
       dflag <- G.getSessionDynFlags
       return $ showPage dflag st sdoc

core/GhcMod/FileMapping.hs

@@ -19,6 +19,7 @@ import System.Directory
 import Control.Monad.Trans.Maybe
 import GHC
 import Control.Monad
+import Language.Preprocessor.Unlit (unlit)
 
 {- | maps 'FilePath', given as first argument to take source from
 'FilePath' given as second argument. Works exactly the same as
@@ -31,7 +32,9 @@ loadMappedFile :: IOish m
                => FilePath -- ^ \'from\', file that will be mapped
                -> FilePath -- ^ \'to\', file to take source from
                -> GhcModT m ()
-loadMappedFile from to = loadMappedFile' from to False
+loadMappedFile from to = do
+  src <- liftIO $ readFile to
+  loadMappedFileSource from src
 
 {- |
 maps 'FilePath', given as first argument to have source as given
@@ -48,20 +51,31 @@ loadMappedFileSource from src = do
   tmpdir <- cradleTempDir `fmap` cradle
   enc <- liftIO . mkTextEncoding . optEncoding =<< options
   to <- liftIO $ do
-    (fn, h) <- openTempFile tmpdir (takeFileName from)
+    let fileName = takeFileName from
+        (fileName', src')
+          | snd (splitExtension fileName) == ".lhs"
+          = (takeBaseName fileName ++ ".hs", unlit from src)
+          | otherwise = (fileName, src)
+        linePragma = "{-# LINE 1 \""++escape from++"\" #-}\n"
+    (fn, h) <- openTempFile tmpdir fileName'
     hSetEncoding h enc
-    hPutStr h src
+    hPutStr h linePragma
+    hPutStr h src'
     hClose h
     return fn
-  loadMappedFile' from to True
+  loadMappedFile' from to
+  where escape (x:xs) = if x `elem` "\\\""
+                        then '\\':x:escape xs
+                        else x:escape xs
+        escape [] = []
 
-loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()
-loadMappedFile' from to isTemp = do
+loadMappedFile' :: IOish m => FilePath -> FilePath -> GhcModT m ()
+loadMappedFile' from to = do
   cfn <- getCanonicalFileNameSafe from
   unloadMappedFile' cfn
   crdl <- cradle
   let to' = makeRelative (cradleRootDir crdl) to
-  addMMappedFile cfn (FileMapping to' isTemp)
+  addMMappedFile cfn (FileMapping to')
 
 mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target
 mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do
@@ -95,7 +109,7 @@ unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile'
 unloadMappedFile' :: IOish m => FilePath -> GhcModT m ()
 unloadMappedFile' cfn = void $ runMaybeT $ do
   fm <- MaybeT $ lookupMMappedFile cfn
-  liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)
+  liftIO $ removeFile (fmPath fm)
   delMMappedFile cfn
 
 fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>

core/GhcMod/Gap.hs

@@ -79,15 +79,10 @@ import SysTools
 import GHCi (stopIServ)
 #endif
 
-import qualified Name
 import qualified InstEnv
 import qualified Pretty
 import qualified StringBuffer as SB
 
-#if __GLASGOW_HASKELL__ >= 710
-import CoAxiom (coAxiomTyCon)
-#endif
-
 #if __GLASGOW_HASKELL__ >= 708
 import FamInstEnv
 import ConLike (ConLike(..))
@@ -411,8 +406,8 @@ filterOutChildren get_thing xs
   where
     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 
-infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc
-infoThing m (Expression str) = do
+infoThing :: GhcMonad m => Expression -> m SDoc
+infoThing (Expression str) = do
     names <- parseName str
 #if __GLASGOW_HASKELL__ >= 708
     mb_stuffs <- mapM (getInfo False) names
@@ -421,61 +416,30 @@ infoThing m (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 m False) filtered)
+    return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
 
 #if __GLASGOW_HASKELL__ >= 708
-pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
-pprInfo m _ (thing, fixity, insts, famInsts)
-    = pprTyThingInContextLoc' thing
+pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
+pprInfo _ (thing, fixity, insts, famInsts)
+    = pprTyThingInContextLoc thing
    $$ show_fixity fixity
-   $$ vcat (map pprInstance' insts)
-   $$ vcat (map pprFamInst' famInsts)
+   $$ InstEnv.pprInstances insts
+   $$ pprFamInsts famInsts
+  where
+    show_fixity fx
+      | fx == defaultFixity = Outputable.empty
+      | otherwise           = ppr fx <+> ppr (getName thing)
 #else
-pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
-pprInfo m pefas (thing, fixity, insts)
-    = pprTyThingInContextLoc' pefas thing
+pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
+pprInfo pefas (thing, fixity, insts)
+    = pprTyThingInContextLoc pefas thing
    $$ show_fixity fixity
-   $$ vcat (map pprInstance' insts)
-#endif
+   $$ vcat (map pprInstance insts)
   where
     show_fixity fx
       | fx == defaultFixity = Outputable.empty
       | otherwise           = ppr fx <+> ppr (getName thing)
-#if __GLASGOW_HASKELL__ >= 708
-    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
-#if __GLASGOW_HASKELL__ >= 710
-    pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
-      = pprTyThingInContextLoc (ATyCon rep_tc)
-
-    pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
-                        , fi_tys = lhs_tys, fi_rhs = rhs })
-      = showWithLoc (pprDefinedAt' (getName axiom)) $
-        hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
-           2 (equals <+> ppr rhs)
-#else
-    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
-#endif
-#else
-    pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
-#endif
-    showWithLoc loc doc
-        = hang doc 2 (char '\t' <> comment <+> loc)
-        -- The tab tries to make them line up a bit
-      where
-        comment = ptext (sLit "--")
-    pprInstance' ispec = hang (pprInstanceHdr ispec)
-        2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
-    pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
-    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
+#endif
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------

core/GhcMod/Logger.hs

@@ -24,16 +24,12 @@ import HscTypes
 import Outputable
 import qualified GHC as G
 import Bag
-import SrcLoc
-import FastString
-
 import GhcMod.Convert
 import GhcMod.Doc (showPage)
 import GhcMod.DynFlags (withDynFlags)
 import GhcMod.Monad.Types
 import GhcMod.Error
 import GhcMod.Pretty
-import GhcMod.Utils (mkRevRedirMapFunc)
 import qualified GhcMod.Gap as Gap
 import Prelude
 
@@ -43,9 +39,7 @@ data Log = Log [String] Builder
 
 newtype LogRef = LogRef (IORef Log)
 
-data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags
-                         , gpeMapFile :: FilePath -> FilePath
-                         }
+newtype GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags }
 
 type GmPprEnvM a = Reader GmPprEnv a
 
@@ -61,13 +55,13 @@ readAndClearLogRef (LogRef ref) = do
     writeIORef ref emptyLog
     return $ b []
 
-appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
-appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
+appendLogRef :: DynFlags -> LogRef -> Gap.GmLogAction
+appendLogRef df (LogRef ref) _reason _df sev src st msg =
     modifyIORef ref update
   where
     -- TODO: get rid of ppMsg and just do more or less what ghc's
     -- defaultLogAction does
-    l = ppMsg map_file df st src sev msg
+    l = ppMsg df st src sev msg
 
     update lg@(Log ls b)
       | l `elem` ls = lg
@@ -92,18 +86,15 @@ withLogger f action = do
 withLogger' :: (IOish m, GmState m, GmEnv m)
     => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
 withLogger' env action = do
-    logref <- liftIO $ newLogRef
-
-    rfm <- mkRevRedirMapFunc
+    logref <- liftIO newLogRef
 
-    let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref
+    let setLogger df = Gap.setLogAction df $ appendLogRef df logref
         handlers = [
             GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,
             GHandler $ \ex -> return $ Left [renderGm $ ghcExceptionDoc ex]
           ]
         gpe = GmPprEnv {
                 gpeDynFlags = hsc_dflags env
-              , gpeMapFile = rfm
         }
 
     a <- gcatches (Right <$> action setLogger) handlers
@@ -112,11 +103,10 @@ withLogger' env action = do
     return ((,) ls <$> a)
 
 errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
-errBagToStrList env errs = do
-   rfm <- mkRevRedirMapFunc
+errBagToStrList env errs =
    return $ runReader
     (errsToStr (sortMsgBag errs))
-    GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }
+    GmPprEnv{ gpeDynFlags = hsc_dflags env }
 
 ----------------------------------------------------------------
 
@@ -137,46 +127,25 @@ ppErrMsg err = do
     GmPprEnv {..} <- ask
     let unqual = errMsgContext err
         st = Gap.mkErrStyle' gpeDynFlags unqual
-        err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
+        err' = Gap.setErrorMsgSpan err $ Gap.errorMsgSpan err
     return $ showPage gpeDynFlags st $ pprLocErrMsg err'
 
-mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
-mapSrcSpanFile map_file (RealSrcSpan s)   =
-    RealSrcSpan $ mapRealSrcSpanFile map_file s
-mapSrcSpanFile _ (UnhelpfulSpan s) =
-    UnhelpfulSpan s
-
-mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan
-mapRealSrcSpanFile map_file s = let
-    start = mapRealSrcLocFile map_file $ realSrcSpanStart s
-    end   = mapRealSrcLocFile map_file $ realSrcSpanEnd s
-  in
-    mkRealSrcSpan start end
-
-mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc
-mapRealSrcLocFile map_file l = let
-    file = mkFastString $ map_file $ unpackFS $ srcLocFile l
-    line = srcLocLine l
-    col  = srcLocCol l
-  in
-    mkRealSrcLoc file line col
-
-ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String
-ppMsg map_file df st spn sev msg = let
+ppMsg :: DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String
+ppMsg df st spn sev msg = let
     cts = showPage df st msg
   in
-    ppMsgPrefix map_file df spn sev cts ++ cts
+    ppMsgPrefix df spn sev cts ++ cts
 
-ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String
-ppMsgPrefix map_file df spn sev cts =
+ppMsgPrefix :: DynFlags -> SrcSpan -> Severity -> String -> String
+ppMsgPrefix df spn sev cts =
   let
       defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix
   in
     fromMaybe defaultPrefix $ do
       (line,col,_,_) <- Gap.getSrcSpan spn
-      file <- map_file <$> normalise <$> Gap.getSrcFile spn
+      file <- normalise <$> Gap.getSrcFile spn
       return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++
-        if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
+        if any (`isPrefixOf` cts) warningAsErrorPrefixes
           then ""
           else Gap.showSeverityCaption sev
 

core/GhcMod/Types.hs

@@ -70,7 +70,7 @@ data OutputStyle = LispStyle  -- ^ S expression style.
 -- | The type for line separator. Historically, a Null string is used.
 newtype LineSeparator = LineSeparator String deriving (Show)
 
-data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}
+newtype FileMapping =  FileMapping {fmPath :: FilePath}
                   deriving (Eq, Show)
 
 type FileMappingMap = Map FilePath FileMapping

core/GhcMod/Utils.hs

@@ -128,18 +128,6 @@ getCanonicalFileNameSafe fn = do
     splitPath' = splitPath
 #endif
 
-mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
-mkRevRedirMapFunc = do
-  rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles
-  crdl <- cradle
-  return $ \key ->
-    fromMaybe key
-    $ makeRelative (cradleRootDir crdl)
-    <$> M.lookup key rm
-  where
-    mf :: FilePath -> FileMapping -> (FilePath, FilePath)
-    mf from to = (fmPath to, from)
-
 findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]
 findFilesWith' _ [] _ = return []
 findFilesWith' f (d:ds) fileName = do

ghc-mod.cabal

@@ -202,6 +202,7 @@ Library
                       , temporary            < 1.3  && >= 1.2.0.3
                       , text                 < 1.3  && >= 1.2.1.3
                       , transformers-base    < 0.5  && >= 0.4.4
+                      , cpphs                >= 1.18 && < 1.21
 
                       , cabal-helper         < 0.8  && >= 0.7.3.0
                       , ghc                  < 8.2  && >= 7.6
@@ -323,7 +324,7 @@ Test-Suite spec
 
                       , base                 < 4.10 && >= 4.6.0.1
                       , fclabels             < 2.1  && >= 2.0
-                      , hspec                < 2.4  && >= 2.0.0
+                      , hspec                < 2.5  && >= 2.0.0
                       , monad-journal        < 0.8  && >= 0.4
                       , split                < 0.3  && >= 0.2.2
                       , temporary            < 1.3  && >= 1.2.0.3