hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Nikolay Yakimov 2015-08-16 23:20:00 +03:00
parent 20d6d4bae7
commit a5dae2a82d
9 changed files with 151 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Language/Haskell/GhcMod.hs
View File

@ -66,6 +66,7 @@ module Language.Haskell.GhcMod (
, gmUnsafeErrStrLn
-- * FileMapping
, loadMappedFile
, loadMappedFileSource
, unloadMappedFile
) where

63
Language/Haskell/GhcMod/FileMapping.hs
View File

@ -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'

28
Language/Haskell/GhcMod/HomeModuleGraph.hs
View File

@ -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)

8
Language/Haskell/GhcMod/Logger.hs
View File

@ -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}
----------------------------------------------------------------

2
Language/Haskell/GhcMod/Target.hs
View File

@ -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

5
Language/Haskell/GhcMod/Types.hs
View File

@ -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'.

36
Language/Haskell/GhcMod/Utils.hs
View File

@ -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)

18
src/GHCMod.hs
View File

@ -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

118
test/FileMappingSpec.hs
View File

@ -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]\""]