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
2016-05-22 02:55:06 +02:00
parent 3bf84fb64a
commit 31e3c0b500
15 changed files with 141 additions and 115 deletions
--- a/Language/Haskell/GhcMod/Check.hs
+++ b/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 ())

 ----------------------------------------------------------------
--- a/Language/Haskell/GhcMod/DebugLogger.hs
+++ b/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 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'

--- a/Language/Haskell/GhcMod/DynFlags.hs
+++ b/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 $
--- a/Language/Haskell/GhcMod/Flag.hs
+++ b/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
-                 | option <- Gap.fOptions
-                 , prefix <- ["","no-"]
-                 ]
+flags = convert' Gap.ghcCmdOptions
--- a/Language/Haskell/GhcMod/Gap.hs
+++ b/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 (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,23 +217,26 @@ 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]
+#  else
+ 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
--- a/Language/Haskell/GhcMod/Logger.hs
+++ b/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 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
-    (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
+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 <- 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:"