diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs index f4bd658..1cf52a2 100644 --- 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 ()) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/DebugLogger.hs b/Language/Haskell/GhcMod/DebugLogger.hs index b448358..0bd0d59 100644 --- 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 . -{-# 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' diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs index 794dda4..a68a050 100644 --- 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 $ diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs index 5fc3e2b..24cb61b 100644 --- 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 diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 0b44dfd..2659c5a 100644 --- 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 diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index bf52410..74e88f0 100644 --- 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:" diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index 2a3086e..1645c81 100644 --- a/test/CabalHelperSpec.hs +++ b/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"] diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 1ff26e2..9b1ea38 100644 --- a/test/CheckSpec.hs +++ b/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" diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs index 9598fb6..47c2a83 100644 --- a/test/FileMappingSpec.hs +++ b/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" diff --git a/test/FlagSpec.hs b/test/FlagSpec.hs index af5438d..60b624b 100644 --- a/test/FlagSpec.hs +++ b/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"] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index d084b9a..de9f3e4 100644 --- a/test/InfoSpec.hs +++ b/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" diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs index 5562e70..1110e76 100644 --- a/test/MonadSpec.hs +++ b/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' diff --git a/test/data/pattern-synonyms/A.hs b/test/data/pattern-synonyms/A.hs index 75affb6..65ef800 100644 --- a/test/data/pattern-synonyms/A.hs +++ b/test/data/pattern-synonyms/A.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} + module A where data SomeType a b = SomeType (a,b) diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal index ab75969..a4afea2 100644 --- a/test/data/pattern-synonyms/pattern-synonyms.cabal +++ 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 \ No newline at end of file + ghc-options: -Wall + if impl(ghc >= 8.0.1) + ghc-options: -Wno-missing-pattern-synonym-signatures \ No newline at end of file diff --git a/test/data/stack-project/new-template.cabal b/test/data/stack-project/new-template.cabal index c71f211..feba619 100644 --- a/test/data/stack-project/new-template.cabal +++ b/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