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

Merge branch 'release-5.6.0.0' into release

Browse Source
This commit is contained in:
Daniel Gröber
2016-07-10 23:42:13 +02:00
parent bd021e42b3 3d55dad777
commit 0893cb1466
62 changed files with 1254 additions and 485 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
test/CabalHelperSpec.hs
View File

@@ -33,7 +33,11 @@ pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs
| otherwise = pkgOptions (y:xs)
where
stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s)
#if __GLASGOW_HASKELL__ >= 800
name s = reverse $ stripDash $ reverse s
#else
name s = reverse $ stripDash $ stripDash $ reverse s
#endif
idirOpts :: [(c, [String])] -> [(c, [String])]
idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`))
@@ -69,7 +73,7 @@ spec = do
it "extracts build dependencies" $ do
let tdir = "test/data/cabal-project"
opts <- map gmcGhcOpts <$> runD' tdir getComponents
let ghcOpts = head opts
let ghcOpts:_ = opts
pkgs = pkgOptions ghcOpts
pkgs `shouldBe` ["Cabal","base","template-haskell"]

40
test/CaseSplitSpec.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
module CaseSplitSpec where
import Language.Haskell.GhcMod
@@ -12,6 +13,7 @@ main = do
spec :: Spec
spec = do
describe "case split" $ do
#if __GLASGOW_HASKELL__ >= 708
it "does not blow up on HsWithBndrs panic" $ do
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Vect.hs" 24 10
@@ -39,3 +41,41 @@ spec = do
res `shouldBe` "38 21 38 59"++
" \"mlReverse' Nil accum = _mlReverse_body\NUL"++
" mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"
#else
it "does not blow up on HsWithBndrs panic" $ do
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Vect706.hs" 24 10
res `shouldBe` "24 1 24 25"++
" \"mlAppend Nil y = undefined\NUL"++
"mlAppend (Cons x1 x2) y = undefined\"\n"
it "works with case expressions" $ do
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Vect706.hs" 28 20
res `shouldBe` "28 19 28 34"++
" \"Nil -> undefined\NUL"++
" (Cons x'1 x'2) -> undefined\"\n"
it "works with where clauses" $ do
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Vect706.hs" 34 17
res `shouldBe` "34 5 34 37"++
" \"mlReverse' Nil accum = undefined\NUL"++
" mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"
it "works with let bindings" $ do
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Vect706.hs" 38 33
res `shouldBe` "38 21 38 53"++
" \"mlReverse' Nil accum = undefined\NUL"++
" mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"
#endif
it "doesn't crash when source doesn't make sense" $
withDirectory_ "test/data/case-split" $ do
res <- runD $ splits "Crash.hs" 4 6
#if __GLASGOW_HASKELL__ < 710
res `shouldBe` "4 1 4 19 \"test x = undefined\"\n"
#else
res `shouldBe` ""
#endif

6
test/CheckSpec.hs
View File

@@ -58,7 +58,7 @@ spec = do
it "emits warnings generated in GHC's desugar stage" $ do
withDirectory_ "test/data/check-missing-warnings" $ do
res <- runD $ checkSyntax ["DesugarWarnings.hs"]
res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n"
res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`)
#endif
it "works with cabal builtin preprocessors" $ do
@@ -71,7 +71,9 @@ spec = do
it "Uses the right qualification style" $ do
withDirectory_ "test/data/nice-qualification" $ do
res <- runD $ checkSyntax ["NiceQualification.hs"]
#if __GLASGOW_HASKELL__ >= 708
#if __GLASGOW_HASKELL__ >= 800
res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL In an equation for \8216main\8217: main = \"wrong type\"\n"
#elif __GLASGOW_HASKELL__ >= 708
res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n"
#else
res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"

6
test/CradleSpec.hs
View File

@@ -37,14 +37,14 @@ spec = do
it "returns the current directory" $ do
withDirectory_ "/" $ do
curDir <- stripLastDot <$> canonicalizePath "/"
res <- clean_ $ runGmOutDef findCradleNoLog
res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions
cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing
it "finds a cabal file and a sandbox" $ do
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
cradleCurrentDir res `shouldBe`
"test/data/cabal-project/subdir1/subdir2"
@@ -56,7 +56,7 @@ spec = do
it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
cradleCurrentDir res `shouldBe`
"test" </> "data" </> "broken-sandbox"

22
test/FileMappingSpec.hs
View File

@@ -123,24 +123,30 @@ spec = do
res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
res `shouldBe` "File.hs:4:1: Warning: 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
loadMappedFileSource "File.hs" "func a b = (++) a b\n"
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n"
res `shouldBe` "File.hs:1:1: Warning: 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" "File_Redir_Lint.hs"
types "File.hs" 4 12
types False "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 with constraints for redirected files" $ do --
let tdir = "test/data/file-mapping"
res <- runD' tdir $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
types True "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 \"Num a => 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
loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\""
types "File.hs" 1 14
types False "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"
@@ -184,14 +190,14 @@ spec = do
res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
res `shouldBe` "File.hs:6:1: Warning: 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
loadMappedFileSource "File.hs" src
lint defaultLintOpts "File.hs"
res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
res `shouldBe` "File.hs:6:1: Warning: 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
@@ -234,7 +240,7 @@ spec = do
,("Bar.hs", tmpdir </> "Bar_Redir.hs")]
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFile) fm
types "Bar.hs" 5 1
types False "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a memory module using TemplateHaskell" $ do
srcFoo <- readFile "test/data/template-haskell/Foo.hs"
@@ -244,5 +250,5 @@ spec = do
,("Bar.hs", srcBar)]
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFileSource) fm
types "Bar.hs" 5 1
types False "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]

1
test/FindSpec.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
module FindSpec where
import Language.Haskell.GhcMod.Find

4
test/FlagSpec.hs
View File

@@ -9,6 +9,6 @@ import Prelude
spec :: Spec
spec = do
describe "flags" $ do
it "contains at least `-fno-warn-orphans'" $ do
it "contains at least `-fprint-explicit-foralls" $ do
f <- runD $ lines <$> flags
f `shouldContain` ["-fno-warn-orphans"]
f `shouldContain` ["-fprint-explicit-foralls"]

20
test/InfoSpec.hs
View File

@@ -19,17 +19,31 @@ spec = do
describe "types" $ do
it "shows types of the expression and its outers" $ do
let tdir = "test/data/ghc-mod-check"
res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5
res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5
#if __GLASGOW_HASKELL__ >= 800
res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"
#else
res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
#endif
it "shows types of the expression with constraints and its outers" $ do
let tdir = "test/data/ghc-mod-check"
res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5
#if __GLASGOW_HASKELL__ >= 800
res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"
#else
res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
#endif
it "works with a module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell"
res <- runD' tdir $ types "Bar.hs" 5 1
res <- runD' tdir $ types False "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a module that imports another module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell"
res <- runD' tdir $ types "ImportsTH.hs" 3 8
res <- runD' tdir $ types False "ImportsTH.hs" 3 8
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
describe "info" $ do

2
test/LintSpec.hs
View File

@@ -9,7 +9,7 @@ spec = do
describe "lint" $ do
it "can detect a redundant import" $ do
res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs"
res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
context "when no suggestions are given" $ do
it "doesn't output an empty line" $ do

15
test/MonadSpec.hs
View File

@@ -23,6 +23,8 @@ spec = do
mv_ex :: MVar (Either SomeException ())
<- newEmptyMVar
mv_startup_barrier :: MVar ()
<- newEmptyMVar
mv_startup_barrier :: MVar () <- newEmptyMVar
_t1 <- forkOS $ do
@@ -37,6 +39,19 @@ spec = do
res' <- evaluate res
putMVar mv_ex res'
_t1 <- forkOS $ do
-- wait (inside GhcModT) for t2 to receive the exception
_ <- runD $ liftIO $ do
putMVar mv_startup_barrier ()
readMVar mv_ex
return ()
_t2 <- forkOS $ do
readMVar mv_startup_barrier -- wait for t1 to be in GhcModT
res <- try $ runD $ return ()
res' <- evaluate res
putMVar mv_ex res'
ex <- takeMVar mv_ex
isLeft ex `shouldBe` True

4
test/PathsAndFilesSpec.hs
View File

@@ -16,12 +16,12 @@ spec = do
describe "getSandboxDb" $ do
it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory
Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"
Just db <- getSandboxDb crdl
db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
it "returns Nothing if the sandbox config file is broken" $ do
Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"
Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"
getSandboxDb crdl `shouldReturn` Nothing
describe "findCabalFile" $ do

15
test/TestUtils.hs
View File

@@ -6,6 +6,7 @@ module TestUtils (
, runE
, runNullLog
, runGmOutDef
, runLogDef
, shouldReturnError
, isPkgDbAt
, isPkgConfDAt
@@ -43,10 +44,6 @@ extract action = do
Right a -> return a
Left e -> error $ show e
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
withSpecCradle cradledir f = do
gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runGhcModTSpec opt action = do
dir <- getCurrentDirectory
@@ -59,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
where
withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
withSpecCradle cradledir f =
gbracket
(runJournalT $ findSpecCradle (optPrograms opt) cradledir)
(liftIO . cleanupCradle . fst) f
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
@@ -88,6 +92,9 @@ runNullLog action = do
runGmOutDef :: IOish m => GmOutT m a -> m a
runGmOutDef = runGmOutT defaultOptions
runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a
runLogDef = fmap fst . runJournalT . runGmOutDef
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
-> Expectation

4
test/data/case-split/Crash.hs Normal file
View File

@@ -0,0 +1,4 @@
module Crash where
test :: Maybe a
test x = undefined

39
test/data/case-split/Vect706.hs Normal file
View File

@@ -0,0 +1,39 @@
{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}
module Vect706 where
data Nat = Z | S Nat
type family (n :: Nat) :+ (m :: Nat) :: Nat
type instance Z :+ m = m
type instance S n :+ m = S (n :+ m)
data Vect :: Nat -> * -> * where
VNil :: Vect Z a
(:::) :: a -> Vect n a -> Vect (S n) a
vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a
vAppend x y = undefined
lAppend :: [a] -> [a] -> [a]
lAppend x y = undefined
data MyList a = Nil | Cons a (MyList a)
mlAppend :: MyList a -> MyList a -> MyList a
mlAppend x y = undefined
mlAppend2 :: MyList a -> MyList a -> MyList a
mlAppend2 x y = case x of
x' -> undefined
mlReverse :: MyList a -> MyList a
mlReverse xs = mlReverse' xs Nil
where
mlReverse' :: MyList a -> MyList a -> MyList a
mlReverse' xs' accum = undefined
mlReverse2 :: MyList a -> MyList a
mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a
mlReverse' xs' accum = undefined
in mlReverse' xs Nil

1
test/data/pattern-synonyms/A.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE PatternSynonyms #-}
module A where
data SomeType a b = SomeType (a,b)

4
test/data/pattern-synonyms/pattern-synonyms.cabal
View File

@@ -22,4 +22,6 @@ library
build-depends: base
-- hs-source-dirs:
default-language: Haskell2010
ghc-options: -Wall
ghc-options: -Wall
if impl(ghc >= 8.0.1)
ghc-options: -Wno-missing-pattern-synonym-signatures

2
test/data/stack-project/new-template.cabal
View File

@@ -16,7 +16,7 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Lib
build-depends: base >= 4.7 && < 5
build-depends: base
default-language: Haskell2010
executable new-template-exe