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

Language/Haskell/GhcMod/Check.hs

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

Language/Haskell/GhcMod/DebugLogger.hs

@@ -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 _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
       SevOutput      -> printSDoc putErr msg style'
 

Language/Haskell/GhcMod/DynFlags.hs

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

Language/Haskell/GhcMod/Flag.hs

@@ -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
+flags = convert' Gap.ghcCmdOptions
-                 | option <- Gap.fOptions
-                 , prefix <- ["","no-"]
-                 ]

Language/Haskell/GhcMod/Gap.hs

@@ -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
-import PatSyn (PatSyn)
-#else
-import PatSyn (patSynType)
-#endif
 #else
 import TcRnTypes
 #endif
@@ -152,18 +150,25 @@ withStyle = withPprStyleDoc
 withStyle _ = withPprStyleDoc
 #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
-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
+#if __GLASGOW_HASKELL__ >= 800
-    df { log_action = f }
+    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,23 +217,26 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
 
 ----------------------------------------------------------------
 
-fOptions :: [String]
+ghcCmdOptions :: [String]
 #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
-        ++ [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,_,_) <- fLangFlags]
-#else
+#  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,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
-                         | GtPatSyn PatSyn
+              | GtPatSyn PatSyn
 #endif
 
 fromTyThing :: TyThing -> GapThing

Language/Haskell/GhcMod/Logger.hs

@@ -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 SrcLoc
-import DynFlags (WarnReason)
+import FastString
-#endif
 
 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 -> 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
   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)
       | 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
+        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 = "Dummy:0:0:Error:"

test/CabalHelperSpec.hs

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

test/CheckSpec.hs

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

test/FileMappingSpec.hs

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

test/FlagSpec.hs

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

test/InfoSpec.hs

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

test/MonadSpec.hs

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

test/data/pattern-synonyms/A.hs

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

test/data/pattern-synonyms/pattern-synonyms.cabal

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

test/data/stack-project/new-template.cabal

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