From a205c44dd63fb2bf6622639d13a2de06d8d289c1 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 13:44:15 +0300 Subject: [PATCH 1/8] Revert "Fix mapping subst in info for insts add type fams" This reverts commit 11a1ad2cf3e75fc6b7604cdbb60d573421ec7d5a. --- core/GhcMod/Gap.hs | 38 +++++++++----------------------------- 1 file changed, 9 insertions(+), 29 deletions(-) diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index 728a04ca9..1b9dfbb55 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -84,10 +84,6 @@ 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(..)) @@ -428,44 +424,28 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F pprInfo m _ (thing, fixity, insts, famInsts) = pprTyThingInContextLoc' thing $$ show_fixity fixity - $$ vcat (map pprInstance' insts) - $$ vcat (map pprFamInst' famInsts) + $$ InstEnv.pprInstances insts + $$ pprFamInsts famInsts #else 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) + $$ 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' = 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 + pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2 + (char '\t' <> ptext (sLit "--") <+> loc) + where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #else - pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing') + pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2 + (char '\t' <> ptext (sLit "--") <+> loc) + where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName 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) From 566343243a8caa07aa91d957c360f2c3f3f1fb4d Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 13:47:55 +0300 Subject: [PATCH 2/8] Revert "Replace redirected filenames in info." This reverts commit e7329a9d246c80504b0506f24efd7f66de656dde. --- GhcMod/Exe/Info.hs | 4 +--- core/GhcMod/Gap.hs | 44 ++++++++++++++------------------------------ 2 files changed, 15 insertions(+), 33 deletions(-) diff --git a/GhcMod/Exe/Info.hs b/GhcMod/Exe/Info.hs index 0021936fc..7f0a3f9e3 100644 --- a/GhcMod/Exe/Info.hs +++ b/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 diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs index 1b9dfbb55..20776d5d3 100644 --- a/core/GhcMod/Gap.hs +++ b/core/GhcMod/Gap.hs @@ -79,7 +79,6 @@ import SysTools import GHCi (stopIServ) #endif -import qualified Name import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB @@ -407,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 @@ -417,45 +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 $$ 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 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 +#endif ---------------------------------------------------------------- ---------------------------------------------------------------- From d6f8e9dfc9246479799c6473032b11359d5a2023 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 13:54:41 +0300 Subject: [PATCH 3/8] Bump hspec --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index e0b48232d..01a47d46c 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -323,7 +323,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 From ef8379d8016826980cc68dc62692b3732a2837ac Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 13:55:10 +0300 Subject: [PATCH 4/8] Use LINE pragma in mapped files --- core/GhcMod/FileMapping.hs | 9 +++++- core/GhcMod/Logger.hs | 63 ++++++++++---------------------------- core/GhcMod/Utils.hs | 12 -------- 3 files changed, 24 insertions(+), 60 deletions(-) diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs index e05a54066..a378c9ad2 100644 --- a/core/GhcMod/FileMapping.hs +++ b/core/GhcMod/FileMapping.hs @@ -31,7 +31,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 @@ -50,10 +52,15 @@ loadMappedFileSource from src = do to <- liftIO $ do (fn, h) <- openTempFile tmpdir (takeFileName from) hSetEncoding h enc + hPutStr h $ "{-# LINE 1 \""++escape from++"\" #-}\n" hPutStr h src hClose h return fn loadMappedFile' from to True + 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 diff --git a/core/GhcMod/Logger.hs b/core/GhcMod/Logger.hs index 3ccf89bdb..3ebe02e11 100644 --- a/core/GhcMod/Logger.hs +++ b/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 diff --git a/core/GhcMod/Utils.hs b/core/GhcMod/Utils.hs index 38062b6f4..364657b31 100644 --- a/core/GhcMod/Utils.hs +++ b/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 From 65f4c11bed2c637a4888a90ad5c72d23684f0730 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 15:02:06 +0300 Subject: [PATCH 5/8] Unlit mapped lhs --- core/GhcMod/FileMapping.hs | 13 ++++++++++--- ghc-mod.cabal | 1 + 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs index a378c9ad2..65e4c771d 100644 --- a/core/GhcMod/FileMapping.hs +++ b/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 @@ -50,10 +51,16 @@ 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 $ "{-# LINE 1 \""++escape from++"\" #-}\n" - hPutStr h src + hPutStr h linePragma + hPutStr h src' hClose h return fn loadMappedFile' from to True diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 01a47d46c..c668b43ad 100644 --- a/ghc-mod.cabal +++ b/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 From 8f15c62308e8ad8fd1eaa6519e72372d669d2be3 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 15:02:48 +0300 Subject: [PATCH 6/8] Remove temp flags on mapped files (all mapped files are temp) --- core/GhcMod/FileMapping.hs | 10 +++++----- core/GhcMod/Types.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs index 65e4c771d..e82910771 100644 --- a/core/GhcMod/FileMapping.hs +++ b/core/GhcMod/FileMapping.hs @@ -63,19 +63,19 @@ loadMappedFileSource from src = do 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 @@ -109,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) => diff --git a/core/GhcMod/Types.hs b/core/GhcMod/Types.hs index 7eccdac89..98eeac326 100644 --- a/core/GhcMod/Types.hs +++ b/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 From ae036f5d428eb40fa5f7a49d5f538456e0d6ed41 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 15:03:02 +0300 Subject: [PATCH 7/8] Update FileMap spec --- test/FileMappingSpec.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index aec284d23..eeba3dca8 100644 --- a/test/FileMappingSpec.hs +++ b/test/FileMappingSpec.hs @@ -8,6 +8,7 @@ import qualified Data.Map as M import Dir import System.IO.Temp import System.Directory +import Data.Maybe import GhcMod @@ -20,14 +21,14 @@ spec = do loadMappedFile "File.hs" "File.hs" getMMappedFiles dir <- getCurrentDirectory - show mappedFiles `shouldBe` show (M.fromList [(dir "File.hs", FileMapping "File.hs" False)]) + M.lookup (dir "File.hs") mappedFiles `shouldSatisfy` isJust it "should try to guess a canonical name if file doesn't exist" $ do withDirectory_ "test/data/file-mapping" $ do mappedFiles <- runD $ do loadMappedFile "NonExistantFile.hs" "File.hs" getMMappedFiles dir <- getCurrentDirectory - show mappedFiles `shouldBe` show (M.fromList [(dir "NonExistantFile.hs", FileMapping "File.hs" False)]) + M.lookup (dir "NonExistantFile.hs") mappedFiles `shouldSatisfy` isJust describe "loadMappedFileSource" $ do it "inserts a given FilePath FileMapping into state with canonicalized path" $ do @@ -37,7 +38,7 @@ spec = do getMMappedFiles dir <- getCurrentDirectory -- TODO - M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] -> + M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to)] -> fn == dir "File.hs" it "should try to guess a canonical name if file doesn't exist" $ do withDirectory_ "test/data/file-mapping" $ do @@ -46,24 +47,24 @@ spec = do getMMappedFiles dir <- getCurrentDirectory -- TODO - M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] -> + M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to)] -> fn == dir "NonExistantFile.hs" describe "unloadMappedFile" $ do it "removes a given FilePath from state" $ do withDirectory_ "test/data/file-mapping" $ do mappedFiles <- runD $ do - loadMappedFile "File.hs" "File2.hs" + loadMappedFile "File.hs" "File_Redir.hs" unloadMappedFile "File.hs" getMMappedFiles - show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)])) + mappedFiles `shouldSatisfy` M.null it "should work even if file does not exist" $ do withDirectory_ "test/data/file-mapping" $ do mappedFiles <- runD $ do - loadMappedFile "NonExistantFile.hs" "File2.hs" + loadMappedFile "NonExistantFile.hs" "File_Redir.hs" unloadMappedFile "NonExistantFile.hs" getMMappedFiles - show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)])) + mappedFiles `shouldSatisfy` M.null it "should remove created temporary files" $ do withDirectory_ "test/data/file-mapping" $ do dir <- getCurrentDirectory @@ -80,7 +81,7 @@ spec = do res <- runD $ do loadMappedFile "File.hs" "File_Redir.hs" withMappedFile "File.hs" return - res `shouldBe` "File_Redir.hs" + res `shouldNotBe` "File.hs" it "checks if there is an in-memory file and calls and action with temporary file" $ do withDirectory_ "test/data/file-mapping" $ do (fn, src) <- runD $ do @@ -89,7 +90,7 @@ spec = do src <- liftIO $ readFile fn return (fn, src) fn `shouldSatisfy` (/="File.hs") - src `shouldBe` "main = test" + last (lines src) `shouldBe` "main = test" it "runs action with original filename if there is no mapping" $ do withDirectory_ "test/data/file-mapping" $ do fn <- runD $ do From 19397104f858d4e2ebbcb786be73a22e1a0f6f90 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Wed, 23 Aug 2017 15:04:24 +0300 Subject: [PATCH 8/8] Ignore .cabal-sandbox-es in test data --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index c3e127b1f..fb6dd13bd 100644 --- a/.gitignore +++ b/.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