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
(map Left files)
return
((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
(return ())
----------------------------------------------------------------

View File

@ -13,7 +13,7 @@
--
-- 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/>.
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.DebugLogger where
-- (c) The University of Glasgow 2005
@ -62,11 +62,7 @@ import Language.Haskell.GhcMod.Gap
import Prelude
debugLogAction :: (String -> IO ()) -> GmLogAction
#if __GLASGOW_HASKELL__ >= 800
debugLogAction putErr dflags _reason severity srcSpan style' msg
#else
debugLogAction putErr dflags severity srcSpan style' msg
#endif
debugLogAction putErr _reason dflags severity srcSpan style' msg
= case severity of
SevOutput -> printSDoc putErr msg style'

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlags where
@ -16,11 +16,7 @@ import Prelude
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df =
#if __GLASGOW_HASKELL__ >= 800
Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
#else
Gap.setLogAction df $ \_ _ _ _ _ -> return ()
#endif
setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
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 df = return $
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.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 = convert' [ "-f" ++ prefix ++ option
| option <- Gap.fOptions
, prefix <- ["","no-"]
]
flags = convert' Gap.ghcCmdOptions

View File

@ -9,7 +9,7 @@ module Language.Haskell.GhcMod.Gap (
, getSrcSpan
, getSrcFile
, withInteractiveContext
, fOptions
, ghcCmdOptions
, toStringBuffer
, showSeverityCaption
, setCabalPkg
@ -18,12 +18,14 @@ module Language.Haskell.GhcMod.Gap (
, setDeferTypedHoles
, setWarnTypedHoles
, setDumpSplices
, setNoMaxRelevantBindings
, isDumpSplices
, filterOutChildren
, infoThing
, pprInfo
, HasType(..)
, errorMsgSpan
, setErrorMsgSpan
, typeForUser
, nameForUser
, occNameForUser
@ -83,11 +85,7 @@ import CoAxiom (coAxiomTyCon)
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
#if __GLASGOW_HASKELL__ >= 800
import PatSyn (PatSyn)
#else
import PatSyn (patSynType)
#endif
import PatSyn
#else
import TcRnTypes
#endif
@ -152,18 +150,25 @@ withStyle = withPprStyleDoc
withStyle _ = withPprStyleDoc
#endif
#if __GLASGOW_HASKELL__ >= 706
type GmLogAction = LogAction
#if __GLASGOW_HASKELL__ >= 800
-- flip LogAction
type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
#elif __GLASGOW_HASKELL__ >= 706
type GmLogAction = forall a. a -> LogAction
#else
type GmLogAction = DynFlags -> LogAction
type GmLogAction = forall a. a -> DynFlags -> LogAction
#endif
-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
setLogAction :: DynFlags -> GmLogAction -> DynFlags
setLogAction df f =
#if __GLASGOW_HASKELL__ >= 706
df { log_action = f }
#if __GLASGOW_HASKELL__ >= 800
df { log_action = flip f }
#elif __GLASGOW_HASKELL__ >= 706
df { log_action = f (error "setLogAction") }
#else
df { log_action = f df }
df { log_action = f (error "setLogAction") df }
#endif
showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String
@ -212,24 +217,27 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
----------------------------------------------------------------
fOptions :: [String]
ghcCmdOptions :: [String]
#if __GLASGOW_HASKELL__ >= 710
fOptions = [option | (FlagSpec option _ _ _) <- fFlags]
#if __GLASGOW_HASKELL__ >= 800
++ [option | (FlagSpec option _ _ _) <- wWarningFlags]
-- this also includes -X options and all sorts of other things so the
ghcCmdOptions = flagsForCompletion False
#else
++ [option | (FlagSpec option _ _ _) <- fWarningFlags]
#endif
++ [option | (FlagSpec option _ _ _) <- fLangFlags]
#elif __GLASGOW_HASKELL__ >= 704
fOptions = [option | (option,_,_) <- fFlags]
ghcCmdOptions = [ "-f" ++ prefix ++ option
| option <- opts
, prefix <- ["","no-"]
]
# if __GLASGOW_HASKELL__ >= 704
where opts =
[option | (option,_,_) <- fFlags]
++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags]
# else
fOptions = [option | (option,_,_,_) <- fFlags]
where opts =
[option | (option,_,_,_) <- fFlags]
++ [option | (option,_,_,_) <- fWarningFlags]
++ [option | (option,_,_,_) <- fLangFlags]
# endif
#endif
----------------------------------------------------------------
----------------------------------------------------------------
@ -330,6 +338,16 @@ setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
setWarnTypedHoles = id
#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
#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
#if __GLASGOW_HASKELL__ >= 708
typeForUser = pprTypeForUser
@ -463,7 +488,9 @@ 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
| GtPatSyn PatSyn
#endif

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.Logger (
withLogger
@ -14,7 +14,7 @@ import Data.Ord
import Data.List
import Data.Maybe
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 System.FilePath (normalise)
import Text.PrettyPrint
@ -25,9 +25,8 @@ import HscTypes
import Outputable
import qualified GHC as G
import Bag
#if __GLASGOW_HASKELL__ >= 800
import DynFlags (WarnReason)
#endif
import SrcLoc
import FastString
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage)
@ -62,20 +61,13 @@ readAndClearLogRef (LogRef ref) = do
writeIORef ref emptyLog
return $ b []
#if __GLASGOW_HASKELL__ >= 800
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
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
appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
modifyIORef ref update
where
gpe = GmPprEnv {
gpeDynFlags = df
, gpeMapFile = rfm
}
l = runReader (ppMsg st src sev msg) gpe
-- 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
update lg@(Log ls b)
| l `elem` ls = lg
@ -142,44 +134,51 @@ sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
ppErrMsg :: ErrMsg -> GmPprEnvM String
ppErrMsg err = do
dflags <- asks gpeDynFlags
GmPprEnv {..} <- ask
let unqual = errMsgContext err
st = Gap.mkErrStyle' dflags unqual
#if __GLASGOW_HASKELL__ >= 800
return $ showPage dflags st msg
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
st = Gap.mkErrStyle' gpeDynFlags unqual
err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
return $ showPage gpeDynFlags st $ pprLocErrMsg err'
ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String
ppMsg st spn sev msg = do
dflags <- asks gpeDynFlags
let cts = showPage dflags st msg
prefix <- ppMsgPrefix spn sev cts
return $ prefix ++ cts
mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
mapSrcSpanFile map_file (RealSrcSpan s) =
RealSrcSpan $ mapRealSrcSpanFile map_file s
mapSrcSpanFile _ (UnhelpfulSpan s) =
UnhelpfulSpan s
ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String
ppMsgPrefix spn sev cts = do
dflags <- asks gpeDynFlags
mr <- asks gpeMapFile
let defaultPrefix
| Gap.isDumpSplices dflags = ""
| otherwise = checkErrorPrefix
return $ fromMaybe defaultPrefix $ do
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
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 <- mr <$> normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
= file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
return pref0
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 = "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)
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"]

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"

View File

@ -136,7 +136,7 @@ spec = do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
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
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"

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

View File

@ -20,12 +20,21 @@ spec = do
it "shows types of the expression and its outers" $ do
let tdir = "test/data/ghc-mod-check"
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"

View File

@ -23,16 +23,18 @@ spec = do
mv_ex :: MVar (Either SomeException ())
<- newEmptyMVar
mv_startup_barrier :: MVar () <- newEmptyMVar
mv_startup_barrier :: MVar ()
<- newEmptyMVar
_t1 <- forkOS $ do
putMVar mv_startup_barrier ()
-- 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 ()
_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' <- evaluate res
putMVar mv_ex res'

View File

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

View File

@ -23,3 +23,5 @@ library
-- hs-source-dirs:
default-language: Haskell2010
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
hs-source-dirs: src
exposed-modules: Lib
build-depends: base >= 4.7 && < 5
build-depends: base
default-language: Haskell2010
executable new-template-exe