Housekeeping for GHC 8

- Remove some CPP needed only because of GHC 7.4 (which is not supported
  now, yey)
- Move CPP for GHC 8 to Gap module
This commit is contained in:
Daniel Gröber 2016-05-22 02:55:06 +02:00
parent 3bf84fb64a
commit 31e3c0b500
15 changed files with 141 additions and 115 deletions

View File

@ -33,7 +33,7 @@ check files =
runGmlTWith runGmlTWith
(map Left files) (map Left files)
return return
((fmap fst <$>) . withLogger setNoMaxRelevantBindings) ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
(return ()) (return ())
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -13,7 +13,7 @@
-- --
-- You should have received a copy of the GNU Affero General Public License -- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.DebugLogger where module Language.Haskell.GhcMod.DebugLogger where
-- (c) The University of Glasgow 2005 -- (c) The University of Glasgow 2005
@ -62,11 +62,7 @@ import Language.Haskell.GhcMod.Gap
import Prelude import Prelude
debugLogAction :: (String -> IO ()) -> GmLogAction debugLogAction :: (String -> IO ()) -> GmLogAction
#if __GLASGOW_HASKELL__ >= 800 debugLogAction putErr _reason dflags severity srcSpan style' msg
debugLogAction putErr dflags _reason severity srcSpan style' msg
#else
debugLogAction putErr dflags severity srcSpan style' msg
#endif
= case severity of = case severity of
SevOutput -> printSDoc putErr msg style' SevOutput -> printSDoc putErr msg style'

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlags where module Language.Haskell.GhcMod.DynFlags where
@ -16,11 +16,7 @@ import Prelude
setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df = setEmptyLogger df =
#if __GLASGOW_HASKELL__ >= 800
Gap.setLogAction df $ \_ _ _ _ _ _ -> return () Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
#else
Gap.setLogAction df $ \_ _ _ _ _ -> return ()
#endif
setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
setDebugLogger put df = do setDebugLogger put df = do
@ -99,14 +95,6 @@ allWarningFlags = unsafePerformIO $
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif
deferErrors :: Monad m => DynFlags -> m DynFlags deferErrors :: Monad m => DynFlags -> m DynFlags
deferErrors df = return $ deferErrors df = return $
Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $

View File

@ -4,10 +4,6 @@ import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
-- | Listing GHC flags. (e.g -fno-warn-orphans) -- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@.
flags :: IOish m => GhcModT m String flags :: IOish m => GhcModT m String
flags = convert' [ "-f" ++ prefix ++ option flags = convert' Gap.ghcCmdOptions
| option <- Gap.fOptions
, prefix <- ["","no-"]
]

View File

@ -9,7 +9,7 @@ module Language.Haskell.GhcMod.Gap (
, getSrcSpan , getSrcSpan
, getSrcFile , getSrcFile
, withInteractiveContext , withInteractiveContext
, fOptions , ghcCmdOptions
, toStringBuffer , toStringBuffer
, showSeverityCaption , showSeverityCaption
, setCabalPkg , setCabalPkg
@ -18,12 +18,14 @@ module Language.Haskell.GhcMod.Gap (
, setDeferTypedHoles , setDeferTypedHoles
, setWarnTypedHoles , setWarnTypedHoles
, setDumpSplices , setDumpSplices
, setNoMaxRelevantBindings
, isDumpSplices , isDumpSplices
, filterOutChildren , filterOutChildren
, infoThing , infoThing
, pprInfo , pprInfo
, HasType(..) , HasType(..)
, errorMsgSpan , errorMsgSpan
, setErrorMsgSpan
, typeForUser , typeForUser
, nameForUser , nameForUser
, occNameForUser , occNameForUser
@ -83,11 +85,7 @@ import CoAxiom (coAxiomTyCon)
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
import FamInstEnv import FamInstEnv
import ConLike (ConLike(..)) import ConLike (ConLike(..))
#if __GLASGOW_HASKELL__ >= 800 import PatSyn
import PatSyn (PatSyn)
#else
import PatSyn (patSynType)
#endif
#else #else
import TcRnTypes import TcRnTypes
#endif #endif
@ -152,18 +150,25 @@ withStyle = withPprStyleDoc
withStyle _ = withPprStyleDoc withStyle _ = withPprStyleDoc
#endif #endif
#if __GLASGOW_HASKELL__ >= 706 #if __GLASGOW_HASKELL__ >= 800
type GmLogAction = LogAction -- flip LogAction
type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
#elif __GLASGOW_HASKELL__ >= 706
type GmLogAction = forall a. a -> LogAction
#else #else
type GmLogAction = DynFlags -> LogAction type GmLogAction = forall a. a -> DynFlags -> LogAction
#endif #endif
-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
setLogAction :: DynFlags -> GmLogAction -> DynFlags setLogAction :: DynFlags -> GmLogAction -> DynFlags
setLogAction df f = setLogAction df f =
#if __GLASGOW_HASKELL__ >= 706 #if __GLASGOW_HASKELL__ >= 800
df { log_action = f } df { log_action = flip f }
#elif __GLASGOW_HASKELL__ >= 706
df { log_action = f (error "setLogAction") }
#else #else
df { log_action = f df } df { log_action = f (error "setLogAction") df }
#endif #endif
showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String
@ -212,23 +217,26 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
---------------------------------------------------------------- ----------------------------------------------------------------
fOptions :: [String] ghcCmdOptions :: [String]
#if __GLASGOW_HASKELL__ >= 710 #if __GLASGOW_HASKELL__ >= 710
fOptions = [option | (FlagSpec option _ _ _) <- fFlags] -- this also includes -X options and all sorts of other things so the
#if __GLASGOW_HASKELL__ >= 800 ghcCmdOptions = flagsForCompletion False
++ [option | (FlagSpec option _ _ _) <- wWarningFlags]
#else #else
++ [option | (FlagSpec option _ _ _) <- fWarningFlags] ghcCmdOptions = [ "-f" ++ prefix ++ option
#endif | option <- opts
++ [option | (FlagSpec option _ _ _) <- fLangFlags] , prefix <- ["","no-"]
#elif __GLASGOW_HASKELL__ >= 704 ]
fOptions = [option | (option,_,_) <- fFlags] # if __GLASGOW_HASKELL__ >= 704
where opts =
[option | (option,_,_) <- fFlags]
++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags] ++ [option | (option,_,_) <- fLangFlags]
#else # else
fOptions = [option | (option,_,_,_) <- fFlags] where opts =
[option | (option,_,_,_) <- fFlags]
++ [option | (option,_,_,_) <- fWarningFlags] ++ [option | (option,_,_,_) <- fWarningFlags]
++ [option | (option,_,_,_) <- fLangFlags] ++ [option | (option,_,_,_) <- fLangFlags]
# endif
#endif #endif
---------------------------------------------------------------- ----------------------------------------------------------------
@ -330,6 +338,16 @@ setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
setWarnTypedHoles = id setWarnTypedHoles = id
#endif #endif
----------------------------------------------------------------
-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
setNoMaxRelevantBindings :: DynFlags -> DynFlags
#if __GLASGOW_HASKELL__ >= 708
setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else
setNoMaxRelevantBindings = id
#endif
---------------------------------------------------------------- ----------------------------------------------------------------
---------------------------------------------------------------- ----------------------------------------------------------------
@ -434,6 +452,13 @@ errorMsgSpan = errMsgSpan
errorMsgSpan = head . errMsgSpans errorMsgSpan = head . errMsgSpans
#endif #endif
setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg
#if __GLASGOW_HASKELL__ >= 708
setErrorMsgSpan err s = err { errMsgSpan = s }
#else
setErrorMsgSpan err s = err { errMsgSpans = [s] }
#endif
typeForUser :: Type -> SDoc typeForUser :: Type -> SDoc
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
typeForUser = pprTypeForUser typeForUser = pprTypeForUser
@ -463,9 +488,11 @@ deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e
---------------------------------------------------------------- ----------------------------------------------------------------
---------------------------------------------------------------- ----------------------------------------------------------------
data GapThing = GtA Type | GtT TyCon | GtN data GapThing = GtA Type
| GtT TyCon
| GtN
#if __GLASGOW_HASKELL__ >= 800 #if __GLASGOW_HASKELL__ >= 800
| GtPatSyn PatSyn | GtPatSyn PatSyn
#endif #endif
fromTyThing :: TyThing -> GapThing fromTyThing :: TyThing -> GapThing

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.Logger ( module Language.Haskell.GhcMod.Logger (
withLogger withLogger
@ -14,7 +14,7 @@ import Data.Ord
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Function import Data.Function
import Control.Monad.Reader (Reader, asks, runReader) import Control.Monad.Reader (Reader, ask, runReader)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise) import System.FilePath (normalise)
import Text.PrettyPrint import Text.PrettyPrint
@ -25,9 +25,8 @@ import HscTypes
import Outputable import Outputable
import qualified GHC as G import qualified GHC as G
import Bag import Bag
#if __GLASGOW_HASKELL__ >= 800 import SrcLoc
import DynFlags (WarnReason) import FastString
#endif
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage) import Language.Haskell.GhcMod.Doc (showPage)
@ -62,20 +61,13 @@ readAndClearLogRef (LogRef ref) = do
writeIORef ref emptyLog writeIORef ref emptyLog
return $ b [] return $ b []
#if __GLASGOW_HASKELL__ >= 800 appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
appendLogRef rfm df (LogRef ref) _ _reason sev src st msg = do
#else
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef rfm df (LogRef ref) _ sev src st msg = do
#endif
modifyIORef ref update modifyIORef ref update
where where
gpe = GmPprEnv { -- TODO: get rid of ppMsg and just do more or less what ghc's
gpeDynFlags = df -- defaultLogAction does
, gpeMapFile = rfm l = ppMsg map_file df st src sev msg
}
l = runReader (ppMsg st src sev msg) gpe
update lg@(Log ls b) update lg@(Log ls b)
| l `elem` ls = lg | l `elem` ls = lg
@ -142,44 +134,51 @@ sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
ppErrMsg :: ErrMsg -> GmPprEnvM String ppErrMsg :: ErrMsg -> GmPprEnvM String
ppErrMsg err = do ppErrMsg err = do
dflags <- asks gpeDynFlags GmPprEnv {..} <- ask
let unqual = errMsgContext err let unqual = errMsgContext err
st = Gap.mkErrStyle' dflags unqual st = Gap.mkErrStyle' gpeDynFlags unqual
#if __GLASGOW_HASKELL__ >= 800 err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
return $ showPage dflags st msg return $ showPage gpeDynFlags st $ pprLocErrMsg err'
where
msg = pprLocErrMsg err
#else
let ext = showPage dflags st (errMsgExtraInfo err)
m <- ppMsg st spn SevError msg
return $ m ++ (if null ext then "" else "\n" ++ ext)
where
spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err
#endif
ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
ppMsg st spn sev msg = do mapSrcSpanFile map_file (RealSrcSpan s) =
dflags <- asks gpeDynFlags RealSrcSpan $ mapRealSrcSpanFile map_file s
let cts = showPage dflags st msg mapSrcSpanFile _ (UnhelpfulSpan s) =
prefix <- ppMsgPrefix spn sev cts UnhelpfulSpan s
return $ prefix ++ cts
ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan
ppMsgPrefix spn sev cts = do mapRealSrcSpanFile map_file s = let
dflags <- asks gpeDynFlags start = mapRealSrcLocFile map_file $ realSrcSpanStart s
mr <- asks gpeMapFile end = mapRealSrcLocFile map_file $ realSrcSpanEnd s
let defaultPrefix in
| Gap.isDumpSplices dflags = "" mkRealSrcSpan start end
| otherwise = checkErrorPrefix
return $ fromMaybe defaultPrefix $ do mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc
(line,col,_,_) <- Gap.getSrcSpan spn mapRealSrcLocFile map_file l = let
file <- mr <$> normalise <$> Gap.getSrcFile spn file = mkFastString $ map_file $ unpackFS $ srcLocFile l
let severityCaption = Gap.showSeverityCaption sev line = srcLocLine l
pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) col = srcLocCol l
= file ++ ":" ++ show line ++ ":" ++ show col ++ ":" in
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption mkRealSrcLoc file line col
return pref0
ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String
ppMsg map_file df st spn sev msg = let
cts = showPage df st msg
in
ppMsgPrefix map_file df spn sev cts ++ cts
ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String
ppMsgPrefix map_file 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
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++
if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
then ""
else Gap.showSeverityCaption sev
checkErrorPrefix :: String checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:" checkErrorPrefix = "Dummy:0:0:Error:"

View File

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

View File

@ -58,7 +58,7 @@ spec = do
it "emits warnings generated in GHC's desugar stage" $ do it "emits warnings generated in GHC's desugar stage" $ do
withDirectory_ "test/data/check-missing-warnings" $ do withDirectory_ "test/data/check-missing-warnings" $ do
res <- runD $ checkSyntax ["DesugarWarnings.hs"] 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 #endif
it "works with cabal builtin preprocessors" $ do it "works with cabal builtin preprocessors" $ do
@ -71,7 +71,9 @@ spec = do
it "Uses the right qualification style" $ do it "Uses the right qualification style" $ do
withDirectory_ "test/data/nice-qualification" $ do withDirectory_ "test/data/nice-qualification" $ do
res <- runD $ checkSyntax ["NiceQualification.hs"] 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" 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 #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" 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"

View File

@ -136,7 +136,7 @@ spec = do
loadMappedFile "File.hs" "File_Redir_Lint.hs" loadMappedFile "File.hs" "File_Redir_Lint.hs"
types False "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" 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 it "shows types of the expression with constraints for redirected files" $ do --
let tdir = "test/data/file-mapping" let tdir = "test/data/file-mapping"
res <- runD' tdir $ do res <- runD' tdir $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs" loadMappedFile "File.hs" "File_Redir_Lint.hs"

View File

@ -9,6 +9,6 @@ import Prelude
spec :: Spec spec :: Spec
spec = do spec = do
describe "flags" $ 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 <- runD $ lines <$> flags
f `shouldContain` ["-fno-warn-orphans"] f `shouldContain` ["-fprint-explicit-foralls"]

View File

@ -20,12 +20,21 @@ spec = do
it "shows types of the expression and its outers" $ do it "shows types of the expression and its outers" $ do
let tdir = "test/data/ghc-mod-check" let tdir = "test/data/ghc-mod-check"
res <- runD' tdir $ types False "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" 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 it "shows types of the expression with constraints and its outers" $ do
let tdir = "test/data/ghc-mod-check" let tdir = "test/data/ghc-mod-check"
res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5 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" 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 it "works with a module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell" let tdir = "test/data/template-haskell"

View File

@ -23,16 +23,18 @@ spec = do
mv_ex :: MVar (Either SomeException ()) mv_ex :: MVar (Either SomeException ())
<- newEmptyMVar <- newEmptyMVar
mv_startup_barrier :: MVar () <- newEmptyMVar mv_startup_barrier :: MVar ()
<- newEmptyMVar
_t1 <- forkOS $ do _t1 <- forkOS $ do
putMVar mv_startup_barrier ()
-- wait (inside GhcModT) for t2 to receive the exception -- wait (inside GhcModT) for t2 to receive the exception
_ <- runD $ liftIO $ readMVar mv_ex _ <- runD $ liftIO $ do
putMVar mv_startup_barrier ()
readMVar mv_ex
return () return ()
_t2 <- forkOS $ do _t2 <- forkOS $ do
readMVar mv_startup_barrier -- wait for t1 to start up readMVar mv_startup_barrier -- wait for t1 to be in GhcModT
res <- try $ runD $ return () res <- try $ runD $ return ()
res' <- evaluate res res' <- evaluate res
putMVar mv_ex res' putMVar mv_ex res'

View File

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

View File

@ -23,3 +23,5 @@ library
-- hs-source-dirs: -- hs-source-dirs:
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
if impl(ghc >= 8.0.1)
ghc-options: -Wno-missing-pattern-synonym-signatures

View File

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