From a5dae2a82db189c20fccbd33180bd91b74d7e583 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 16 Aug 2015 23:20:00 +0300 Subject: [PATCH] Drop memory-mapped files, since ghc doesn't play well with those All files are now "redirected", either user-created, or created by ghc-mod itself. --- Language/Haskell/GhcMod.hs | 1 + Language/Haskell/GhcMod/FileMapping.hs | 63 ++++++----- Language/Haskell/GhcMod/HomeModuleGraph.hs | 28 ++--- Language/Haskell/GhcMod/Logger.hs | 8 +- Language/Haskell/GhcMod/Target.hs | 2 +- Language/Haskell/GhcMod/Types.hs | 5 +- Language/Haskell/GhcMod/Utils.hs | 36 ++----- src/GHCMod.hs | 18 ++-- test/FileMappingSpec.hs | 118 ++++++++++++++------- 9 files changed, 151 insertions(+), 128 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index b9e7050..a6a555b 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -66,6 +66,7 @@ module Language.Haskell.GhcMod ( , gmUnsafeErrStrLn -- * FileMapping , loadMappedFile + , loadMappedFileSource , unloadMappedFile ) where diff --git a/Language/Haskell/GhcMod/FileMapping.hs b/Language/Haskell/GhcMod/FileMapping.hs index baca49b..656cea0 100644 --- a/Language/Haskell/GhcMod/FileMapping.hs +++ b/Language/Haskell/GhcMod/FileMapping.hs @@ -1,5 +1,6 @@ module Language.Haskell.GhcMod.FileMapping ( loadMappedFile + , loadMappedFileSource , unloadMappedFile , mapFile , fileModSummaryWithMapping @@ -11,43 +12,55 @@ import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.HomeModuleGraph import Language.Haskell.GhcMod.Utils -import Data.Time +import System.IO +import System.FilePath +import System.Directory import Control.Monad.Trans.Maybe import GHC +import Control.Monad +import Control.Monad.Trans (lift) -loadMappedFile :: IOish m => FilePath -> FileMapping -> GhcModT m () -loadMappedFile from fm = - getCanonicalFileNameSafe from >>= (`addMMappedFile` fm) +loadMappedFile :: IOish m => FilePath -> FilePath -> GhcModT m () +loadMappedFile from to = + getCanonicalFileNameSafe from >>= (`addMMappedFile` FileMapping to False) -mapFile :: (IOish m, GmState m, GhcMonad m) => +loadMappedFileSource :: IOish m => FilePath -> String -> GhcModT m () +loadMappedFileSource from src = do + tmpdir <- cradleTempDir `fmap` cradle + to <- liftIO $ do + (fn, h) <- openTempFile tmpdir (takeFileName from) + hPutStr h src + hClose h + return fn + getCanonicalFileNameSafe from >>= (`addMMappedFile` FileMapping to True) + +mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) => HscEnv -> Target -> m Target mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do mapping <- lookupMMappedFile filePath - mkMappedTarget tid taoc mapping + mkMappedTarget (Just filePath) tid taoc mapping mapFile env (Target tid@(TargetModule moduleName) taoc _) = do - mapping <- runMaybeT $ do - filePath <- MaybeT $ liftIO $ findModulePath env moduleName - MaybeT $ lookupMMappedFile $ mpPath filePath - mkMappedTarget tid taoc mapping + (fp, mapping) <- do + filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName) + mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile + return (filePath, mmf) + mkMappedTarget fp tid taoc mapping -mkMappedTarget :: (IOish m, GmState m, GhcMonad m) => - TargetId -> Bool -> Maybe FileMapping -> m Target -mkMappedTarget _ taoc (Just (RedirectedMapping to)) = - return $ mkTarget (TargetFile to Nothing) taoc Nothing -mkMappedTarget tid taoc (Just (MemoryMapping (Just src))) = do - sb <- toStringBuffer [src] - ct <- liftIO getCurrentTime - return $ mkTarget tid taoc $ Just (sb, ct) -mkMappedTarget tid taoc _ = return $ mkTarget tid taoc Nothing +mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) => + Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target +mkMappedTarget _ _ taoc (Just to) = + return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing +mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing unloadMappedFile :: IOish m => FilePath -> GhcModT m () -unloadMappedFile = (delMMappedFile =<<) . getCanonicalFileNameSafe +unloadMappedFile what = void $ runMaybeT $ do + cfn <- lift $ getCanonicalFileNameSafe what + fm <- MaybeT $ lookupMMappedFile cfn + liftIO $ when (fmTemp fm) $ removeFile (fmPath fm) + delMMappedFile cfn fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) => FilePath -> m ModSummary -fileModSummaryWithMapping fn = do - mmf <- getCanonicalFileNameSafe fn >>= lookupMMappedFile - case mmf of - Just (RedirectedMapping to) -> fileModSummary to - _ -> fileModSummary fn +fileModSummaryWithMapping fn = + withMappedFile fn $ \fn' -> fileModSummary fn' diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 1272f4e..a6ae1f3 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -44,6 +44,7 @@ import Control.Arrow ((&&&)) import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.Trans (lift) import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe @@ -62,7 +63,7 @@ import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils (getMappedFileSource) +import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.Gap (parseModuleHeader) -- | Turn module graph into a graphviz dot file @@ -247,19 +248,9 @@ preprocessFile :: (IOish m, GmEnv m, GmState m) => HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) preprocessFile env file = withLogger' env $ \setDf -> do - src <- runMaybeT $ getMappedFileSource file - let env' = env { hsc_dflags = setDf (hsc_dflags env) } - maybe - (liftIO $ preprocess env' (file, Nothing)) - (preprocessWithTemp env' file) - src - where - preprocessWithTemp env' fn src = do - tmpdir <- cradleTempDir <$> cradle - liftIO $ withTempFile tmpdir fn $ \fn' hndl -> do - hPutStr hndl src - hClose hndl - preprocess env' (fn', Nothing) + withMappedFile file $ \fn -> do + let env' = env { hsc_dflags = setDf (hsc_dflags env) } + liftIO $ preprocess env' (fn, Nothing) fileModuleName :: (IOish m, GmEnv m, GmState m) => HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName)) @@ -269,11 +260,12 @@ fileModuleName env fn = do case ep of Left errs -> do return $ Left errs - Right (_warns, (dflags, procdFile)) -> handler $ do + Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do src <- readFile procdFile case parseModuleHeader src dflags procdFile of - Left errs -> do - return $ Left $ errBagToStrList env errs + Left errs -> return $ Left errs Right (_, lmdl) -> do let HsModule {..} = unLoc lmdl - return $ Right $ unLoc <$> hsmodName + return $ Right $ unLoc <$> hsmodName) + where + leftM f = either (return . Left <=< f) (return . Right) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 57fc650..5423c52 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -108,12 +108,16 @@ withLogger' env action = do return ((,) ls <$> a) -errBagToStrList :: HscEnv -> Bag ErrMsg -> [String] +errBagToStrList :: (Functor m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String] errBagToStrList env errs = let dflags = hsc_dflags env pu = icPrintUnqual dflags (hsc_IC env) st = mkUserStyle pu AllTheWay - in runReader (errsToStr (bagToList errs)) GmPprEnv{gpeDynFlags=dflags, gpePprStyle=st} + in do + rfm <- mkRevRedirMapFunc + return $ runReader + (errsToStr (bagToList errs)) + GmPprEnv{gpeDynFlags=dflags, gpePprStyle=st, gpeMapFile=rfm} ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 5cd5b94..ffdcd1f 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -151,7 +151,7 @@ runGmlTWith efnmns' mdf wrapper action = do let (fns, mns) = partitionEithers efnmns' ccfns = map (cradleCurrentDir crdl ) fns - cfns <- liftIO $ mapM canonicalizePath ccfns + cfns <- mapM getCanonicalFileNameSafe ccfns let serfnmn = Set.fromList $ map Right mns ++ map Left cfns opts <- targetGhcOptions crdl serfnmn let opts' = opts ++ ["-O0"] ++ ghcUserOptions diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 029cd23..b632b2a 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -69,8 +69,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 = RedirectedMapping FilePath - | MemoryMapping (Maybe String) +data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool} deriving Show type FileMappingMap = Map FilePath FileMapping @@ -99,7 +98,7 @@ data Options = Options { -- | If 'True', 'browse' will return fully qualified name , qualified :: Bool , hlintOpts :: [String] - , fileMappings :: [(FilePath,FileMapping)] + , fileMappings :: [(FilePath, Maybe FilePath)] } deriving (Show) -- | A default 'Options'. diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 74b3e49..b675c06 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -26,25 +26,23 @@ module Language.Haskell.GhcMod.Utils ( import Control.Applicative import Data.Char import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (fromMaybe) import Exception import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, - getTemporaryDirectory, canonicalizePath, removeFile) + getTemporaryDirectory, canonicalizePath) import System.Environment import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, (), makeRelative) -import System.IO.Temp (createTempDirectory, openTempFile) -import System.IO (hPutStr, hClose) +import System.IO.Temp (createTempDirectory) import System.Process (readProcess) import Text.Printf import Paths_ghc_mod (getLibexecDir) import Utils import Prelude -import Control.Monad.Trans.Maybe -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] @@ -167,44 +165,26 @@ withMappedFile :: (IOish m, GmState m, GmEnv m) => forall a. FilePath -> (FilePath -> m a) -> m a withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile where - runWithFile (Just (RedirectedMapping to)) = action to - runWithFile (Just (MemoryMapping (Just src))) = do - crdl <- cradle - (fp,hndl) <- liftIO $ openTempFile (cradleTempDir crdl) (takeFileName file) - liftIO $ hPutStr hndl src - liftIO $ hClose hndl - result <- action fp - liftIO $ removeFile fp - return result + runWithFile (Just to) = action $ fmPath to runWithFile _ = action file getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath getCanonicalFileNameSafe fn = do crdl <- cradle - let ccfn = cradleCurrentDir crdl fn + let ccfn = cradleRootDir crdl fn fex <- liftIO $ doesFileExist ccfn if fex then liftIO $ canonicalizePath ccfn else return ccfn -getMappedFileSource :: (IOish m, GmEnv m, GmState m) => FilePath -> MaybeT m String -getMappedFileSource fn = do - mf <- MaybeT $ getCanonicalFileNameSafe fn >>= lookupMMappedFile - case mf of - RedirectedMapping fn' -> liftIO $ readFile fn' - MemoryMapping (Just src) -> return src - _ -> mzero - mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath) mkRevRedirMapFunc = do - rm <- M.fromList <$> mapMaybe (uncurry mf) <$> M.toList <$> getMMappedFiles + 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 -> Maybe (FilePath, FilePath) - mf from (RedirectedMapping to) - = Just (to, from) - mf _ _ = Nothing + mf :: FilePath -> FileMapping -> (FilePath, FilePath) + mf from to = (fmPath to, from) diff --git a/src/GHCMod.hs b/src/GHCMod.hs index c7f5030..34663c4 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -274,8 +274,8 @@ globalArgSpec = , option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $ reqArg "OPT" $ \g o -> let m = case second (drop 1) $ span (/='=') g of - (s,"") -> (s, MemoryMapping Nothing) - (f,t) -> (f, RedirectedMapping t) + (s,"") -> (s, Nothing) + (f,t) -> (f, Just t) in Right $ o { fileMappings = m : fileMappings o } @@ -359,16 +359,10 @@ main = do progMain :: (Options,[String]) -> IO () progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do - let - loadMMappedFiles from (MemoryMapping Nothing) = do - src <- liftIO getFileSourceFromStdin - return (from, MemoryMapping $ Just src) - loadMMappedFiles from x = return (from, x) - fileMappings' <- forM (reverse $ fileMappings globalOptions) $ uncurry loadMMappedFiles case globalCommands cmdArgs of Just s -> gmPutStr s Nothing -> do - mapM_ (uncurry loadMappedFile) fileMappings' + forM_ (reverse $ fileMappings globalOptions) $ uncurry loadMMappedFiles ghcCommands cmdArgs where hndle action = do @@ -378,6 +372,10 @@ progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ return () Left ed -> exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed) + loadMMappedFiles from (Just to) = loadMappedFile from to + loadMMappedFiles from (Nothing) = do + src <- liftIO getFileSourceFromStdin + loadMappedFileSource from src globalCommands :: [String] -> Maybe String globalCommands (cmd:_) @@ -447,7 +445,7 @@ legacyInteractiveLoop symdbreq world = do "browse" -> browseCmd args "map-file" -> liftIO getFileSourceFromStdin - >>= loadMappedFile arg . MemoryMapping . Just + >>= loadMappedFileSource arg >> return "" "unmap-file" -> unloadMappedFile arg diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index 98ad727..8cfe2b0 100644 --- a/test/FileMappingSpec.hs +++ b/test/FileMappingSpec.hs @@ -7,6 +7,7 @@ import TestUtils import qualified Data.Map as M import Dir import System.IO.Temp +import System.Directory import Language.Haskell.GhcMod @@ -16,45 +17,74 @@ spec = do it "inserts a given FilePath FileMapping into state with canonicalized path" $ do withDirectory_ "test/data/file-mapping" $ do mappedFiles <- runD $ do - loadMappedFile "File.hs" (MemoryMapping Nothing) + loadMappedFile "File.hs" "File.hs" getMMappedFiles dir <- getCurrentDirectory - show mappedFiles `shouldBe` show (M.fromList [(dir "File.hs", MemoryMapping Nothing)]) + show mappedFiles `shouldBe` show (M.fromList [(dir "File.hs", FileMapping "File.hs" False)]) 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" (MemoryMapping Nothing) + loadMappedFile "NonExistantFile.hs" "File.hs" getMMappedFiles dir <- getCurrentDirectory - show mappedFiles `shouldBe` show (M.fromList [(dir "NonExistantFile.hs", MemoryMapping Nothing)]) + show mappedFiles `shouldBe` show (M.fromList [(dir "NonExistantFile.hs", FileMapping "File.hs" False)]) + + describe "loadMappedFileSource" $ do + it "inserts a given FilePath FileMapping into state with canonicalized path" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFileSource "File.hs" "main :: IO ()" + getMMappedFiles + dir <- getCurrentDirectory + -- TODO + M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] -> + fn == dir "File.hs" + it "should try to guess a canonical name if file doesn't exist" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFileSource "NonExistantFile.hs" "main :: IO ()" + getMMappedFiles + dir <- getCurrentDirectory + -- TODO + M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] -> + 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" (MemoryMapping Nothing) + loadMappedFile "File.hs" "File2.hs" unloadMappedFile "File.hs" getMMappedFiles show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)])) it "should work even if file does not exist" $ do withDirectory_ "test/data/file-mapping" $ do mappedFiles <- runD $ do - loadMappedFile "NonExistantFile.hs" (MemoryMapping Nothing) + loadMappedFile "NonExistantFile.hs" "File2.hs" unloadMappedFile "NonExistantFile.hs" getMMappedFiles show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)])) + it "should remove created temporary files" $ do + withDirectory_ "test/data/file-mapping" $ do + dir <- getCurrentDirectory + fileExists <- runD $ do + loadMappedFileSource "NonExistantFile.hs" "main :: IO ()" + fp <- maybe undefined fmPath `fmap` lookupMMappedFile (dir "NonExistantFile.hs") + unloadMappedFile "NonExistantFile.hs" + liftIO $ doesFileExist fp + not fileExists `shouldBe` True describe "withMappedFile" $ do it "checks if there is a redirected file and calls and action with its FilePath" $ do withDirectory_ "test/data/file-mapping" $ do res <- runD $ do - loadMappedFile "File.hs" (RedirectedMapping "File_Redir.hs") + loadMappedFile "File.hs" "File_Redir.hs" withMappedFile "File.hs" return res `shouldBe` "File_Redir.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 - loadMappedFile "File.hs" (MemoryMapping $ Just "main = test") + loadMappedFileSource "File.hs" "main = test" withMappedFile "File.hs" $ \fn -> do src <- liftIO $ readFile fn return (fn, src) @@ -69,101 +99,107 @@ spec = do describe "integration tests" $ do it "checks redirected file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping" $ do - let fm = [("File.hs", RedirectedMapping "File_Redir.hs")] + let fm = [("File.hs", "File_Redir.hs")] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFile) fm checkSyntax ["File.hs"] res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" it "checks in-memory file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping" $ do - let fm = [("File.hs", MemoryMapping $ Just "main = putStrLn \"Hello World!\"\n")] + let fm = [("File.hs", "main = putStrLn \"Hello World!\"\n")] res <- run defaultOptions $ do - mapM_ (uncurry loadMappedFile) fm + mapM_ (uncurry loadMappedFileSource) fm checkSyntax ["File.hs"] res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "should work even if file doesn't exist" $ do + withDirectory_ "test/data/file-mapping" $ do + let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")] + res <- run defaultOptions{logLevel=GmDebug} $ do + mapM_ (uncurry loadMappedFileSource) fm + checkSyntax ["Nonexistent.hs"] + res `shouldBe` "Nonexistent.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" it "lints redirected file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping" $ do res <- runD $ do - loadMappedFile "File.hs" (RedirectedMapping "File_Redir_Lint.hs") + loadMappedFile "File.hs" "File_Redir_Lint.hs" lint "File.hs" res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" it "lints in-memory file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping" $ do res <- runD $ do - loadMappedFile "File.hs" (MemoryMapping $ Just "func a b = (++) a b\n") + loadMappedFileSource "File.hs" "func a b = (++) a b\n" lint "File.hs" res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n" it "shows types of the expression for redirected files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do - loadMappedFile "File.hs" (RedirectedMapping "File_Redir_Lint.hs") + loadMappedFile "File.hs" "File_Redir_Lint.hs" types "File.hs" 4 12 res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n" it "shows types of the expression for in-memory files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do - loadMappedFile "File.hs" (MemoryMapping $ Just "main = putStrLn \"Hello!\"") + loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\"" types "File.hs" 1 14 res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n" it "shows info for the expression for redirected files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do - loadMappedFile "File.hs" (RedirectedMapping "File_Redir_Lint.hs") + loadMappedFile "File.hs" "File_Redir_Lint.hs" info "File.hs" $ Expression "func" res `shouldBe` "func :: Num a => a -> a -> a \t-- Defined at File.hs:4:1\n" it "shows info for the expression for in-memory files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do - loadMappedFile "File.hs" (MemoryMapping $ Just "module File where\n\ntestfun = putStrLn \"Hello!\"") + loadMappedFileSource "File.hs" "module File where\n\ntestfun = putStrLn \"Hello!\"" info "File.hs" $ Expression "testfun" res `shouldBe` "testfun :: IO () \t-- Defined at File.hs:3:1\n" describe "preprocessor tests" $ do it "checks redirected file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping/preprocessor" $ do - let fm = [("File.hs", RedirectedMapping "File_Redir.hs")] + let fm = [("File.hs", "File_Redir.hs")] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFile) fm checkSyntax ["File.hs"] res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n" - it "doesn't check in-memory file" $ do + it "checks in-memory file" $ do withDirectory_ "test/data/file-mapping/preprocessor" $ do src <- readFile "File_Redir.hs" - let fm = [("File.hs", MemoryMapping $ Just src)] + let fm = [("File.hs", src)] res <- run defaultOptions $ do - mapM_ (uncurry loadMappedFile) fm + mapM_ (uncurry loadMappedFileSource) fm checkSyntax ["File.hs"] - res `shouldBe` "buffer needs preprocesing; interactive check disabled\n" + res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n" it "lints redirected file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping/preprocessor" $ do res <- runD $ do - loadMappedFile "File.hs" (RedirectedMapping "File_Redir_Lint.hs") + loadMappedFile "File.hs" "File_Redir_Lint.hs" lint "File.hs" res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" it "lints in-memory file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping/preprocessor" $ do src <- readFile "File_Redir_Lint.hs" res <- runD $ do - loadMappedFile "File.hs" (MemoryMapping $ Just src) + loadMappedFileSource "File.hs" src lint "File.hs" res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" describe "literate haskell tests" $ do it "checks redirected file if one is specified and outputs original filename" $ do withDirectory_ "test/data/file-mapping/lhs" $ do - let fm = [("File.lhs", RedirectedMapping "File_Redir.lhs")] + let fm = [("File.lhs", "File_Redir.lhs")] res <- run defaultOptions $ do mapM_ (uncurry loadMappedFile) fm checkSyntax ["File.lhs"] res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n" - -- NOTE: GHC can't 'unliterate' a file in-memory, so this won't work - -- it "checks in-memory file if one is specified and outputs original filename" $ do - -- withDirectory_ "test/data/file-mapping/lhs" $ do - -- src <- readFile "File_Redir.lhs" - -- let fm = [("File.lhs", MemoryMapping $ Just src)] - -- res <- run defaultOptions $ do - -- mapM_ (uncurry loadMappedFile) fm - -- checkSyntax ["File.lhs"] - -- res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "checks in-memory file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping/lhs" $ do + src <- readFile "File_Redir.lhs" + let fm = [("File.lhs", src)] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFileSource) fm + checkSyntax ["File.lhs"] + res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n" -- NOTE: There is a bug in hlint that prevents it from linting lhs files. -- it "lints redirected file if one is specified and outputs original filename" $ do -- withDirectory_ "test/data/file-mapping/lhs" $ do @@ -186,9 +222,9 @@ spec = do withDirectory_ "test/data/file-mapping" $ do writeFile (tmpdir "Foo_Redir.hs") srcFoo writeFile (tmpdir "Bar_Redir.hs") srcBar - let fm = [("Foo.hs", RedirectedMapping $ tmpdir "Foo_Redir.hs") - ,("Bar.hs", RedirectedMapping $ tmpdir "Bar_Redir.hs")] - res <- run defaultOptions $ do + let fm = [("Foo.hs", tmpdir "Foo_Redir.hs") + ,("Bar.hs", tmpdir "Bar_Redir.hs")] + res <- run defaultOptions{logLevel = GmDebug} $ do mapM_ (uncurry loadMappedFile) fm types "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] @@ -196,9 +232,9 @@ spec = do srcFoo <- readFile "test/data/template-haskell/Foo.hs" srcBar <- readFile "test/data/template-haskell/Bar.hs" withDirectory_ "test/data/file-mapping" $ do - let fm = [("Foo.hs", MemoryMapping $ Just srcFoo) - ,("Bar.hs", MemoryMapping $ Just srcBar)] - res <- run defaultOptions $ do - mapM_ (uncurry loadMappedFile) fm + let fm = [("Foo.hs", srcFoo) + ,("Bar.hs", srcBar)] + res <- run defaultOptions{logLevel = GmDebug} $ do + mapM_ (uncurry loadMappedFileSource) fm types "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]