diff --git a/src/Refact/Compat.hs b/src/Refact/Compat.hs index 067eba9..e83c69a 100644 --- a/src/Refact/Compat.hs +++ b/src/Refact/Compat.hs @@ -43,11 +43,7 @@ module Refact.Compat ( StmtLR (..), -- * HsSyn / GHC.Hs -#if __GLASGOW_HASKELL__ >= 810 module GHC.Hs, -#else - module HsSyn, -#endif -- * Name / OccName / GHC.Types.Name nameOccName, @@ -102,130 +98,58 @@ module Refact.Compat ( initParserOpts, ) where -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Data.Bag (unitBag, bagToList ) +import Control.Monad.Trans.State.Strict (StateT) +import Data.Data (Data) +import qualified GHC +import GHC.Data.Bag (unitBag, bagToList) import GHC.Data.FastString (FastString, mkFastString) +import qualified GHC.Data.Strict as Strict import GHC.Data.StringBuffer (stringToStringBuffer) +import GHC.Driver.Errors.Types (ErrorMessages, ghcUnknownMessage) import GHC.Driver.Session hiding (initDynFlags) -import GHC.Parser.Annotation +import GHC.Hs hiding (Pat, Stmt) import GHC.Parser.Header (getOptions) +import GHC.Types.Error (getMessages) import GHC.Types.Fixity ( Fixity(..) ) -import GHC.Utils.Error import GHC.Types.Name (nameOccName, occName, occNameString) import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) import GHC.Types.SrcLoc hiding (spans) import GHC.Types.SourceText -import GHC.Utils.Panic (pprPanic) +import GHC.Utils.Error import GHC.Utils.Outputable ( ppr, showSDocUnsafe, text, vcat, ) -import GHC.Utils.Panic (handleGhcException) -#else -import ApiAnnotation -#if __GLASGOW_HASKELL__ == 810 -import Bag (unitBag) -#endif -import BasicTypes (Fixity (..), SourceText (..)) -import ErrUtils - ( ErrorMessages, - pprErrMsgBagWithLoc, -#if __GLASGOW_HASKELL__ == 810 - mkPlainErrMsg, -#endif - ) -import DynFlags hiding (initDynFlags) -import FastString (FastString, mkFastString) -import GHC.LanguageExtensions.Type (Extension (..)) -import HeaderInfo (getOptions) -import Name (nameOccName) -import OccName (occName, occNameString) -import Outputable - ( ppr, - showSDocUnsafe, -#if __GLASGOW_HASKELL__ == 810 - pprPanic, - text, - vcat, -#endif - ) -import Panic (handleGhcException) -import RdrName (RdrName (..), rdrNameOcc) -import SrcLoc hiding (spans) -import StringBuffer (stringToStringBuffer) -#endif - -#if __GLASGOW_HASKELL__ >= 810 -import GHC.Hs hiding (Pat, Stmt) -#elif __GLASGOW_HASKELL__ <= 808 -import HsSyn hiding (Pat, Stmt) -#endif - -import GHC.Driver.Errors.Types (ErrorMessages, ghcUnknownMessage) -import GHC.Types.Error(getMessages) -import qualified GHC.Data.Strict as Strict +import GHC.Utils.Panic (handleGhcException, pprPanic) import GHC.Driver.Config.Parser - -import Control.Monad.Trans.State.Strict (StateT) -import Data.Data (Data) -import qualified GHC import Language.Haskell.GHC.ExactPrint.Parsers (Parser) import Language.Haskell.GHC.ExactPrint.Utils import Refact.Types (Refactoring) -#if __GLASGOW_HASKELL__ <= 806 -type MonadFail' = Monad -#else type MonadFail' = MonadFail -#endif -#if __GLASGOW_HASKELL__ >= 900 type Module = Located HsModule -#else -type Module = Located (HsModule GhcPs) -#endif -#if __GLASGOW_HASKELL__ >= 810 type Errors = ErrorMessages onError :: String -> Errors -> a onError s = pprPanic s . vcat . ppp ppp :: Errors -> [SDoc] ppp pst = concatMap unDecorated $ fmap (diagnosticMessage . errMsgDiagnostic) $ bagToList $ getMessages pst -#else -type Errors = (SrcSpan, String) -onError :: String -> Errors -> a -onError _ = error . show -#endif -#if __GLASGOW_HASKELL__ >= 900 type FunBind = HsMatchContext GhcPs -#else -type FunBind = HsMatchContext RdrName -#endif pattern RealSrcLoc' :: RealSrcLoc -> SrcLoc -#if __GLASGOW_HASKELL__ >= 900 pattern RealSrcLoc' r <- RealSrcLoc r _ where RealSrcLoc' r = RealSrcLoc r Strict.Nothing -#else -pattern RealSrcLoc' r <- RealSrcLoc r where - RealSrcLoc' r = RealSrcLoc r -#endif {-# COMPLETE RealSrcLoc', UnhelpfulLoc #-} pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan -#if __GLASGOW_HASKELL__ >= 900 pattern RealSrcSpan' r <- RealSrcSpan r _ where RealSrcSpan' r = RealSrcSpan r Strict.Nothing -#else -pattern RealSrcSpan' r <- RealSrcSpan r where - RealSrcSpan' r = RealSrcSpan r -#endif {-# COMPLETE RealSrcSpan', UnhelpfulSpan #-} -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 composeSrcSpan :: a -> a composeSrcSpan = id @@ -233,32 +157,19 @@ decomposeSrcSpan :: a -> a decomposeSrcSpan = id type SrcSpanLess a = a -#endif type AnnSpan = RealSrcSpan badAnnSpan :: AnnSpan badAnnSpan = -#if __GLASGOW_HASKELL__ >= 900 badRealSrcSpan -#else - noSrcSpan -#endif srcSpanToAnnSpan :: SrcSpan -> AnnSpan srcSpanToAnnSpan = -#if __GLASGOW_HASKELL__ >= 900 \case RealSrcSpan l _ -> l; _ -> badRealSrcSpan -#else - id -#endif annSpanToSrcSpan :: AnnSpan -> SrcSpan annSpanToSrcSpan = -#if __GLASGOW_HASKELL__ >= 900 flip RealSrcSpan Strict.Nothing -#else - id -#endif setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan setSrcSpanFile file s @@ -279,29 +190,16 @@ setRealSrcSpanFile file s = mkRealSrcSpan start' end' setAnnSpanFile :: FastString -> AnnSpan -> AnnSpan setAnnSpanFile = -#if __GLASGOW_HASKELL__ >= 900 setRealSrcSpanFile -#else - setSrcSpanFile -#endif mkErr :: DynFlags -> SrcSpan -> String -> Errors -#if __GLASGOW_HASKELL__ >= 810 mkErr _df l s = mkMessages $ unitBag (mkPlainErrorMsgEnvelope l (ghcUnknownMessage $ mkDecoratedError [] [text s])) -#else -mkErr = const (,) -#endif parseModuleName :: SrcSpan -> Parser (LocatedA GHC.ModuleName) parseModuleName ss _ _ s = let newMN = GHC.L (GHC.noAnnSrcSpan ss) (GHC.mkModuleName s) -#if __GLASGOW_HASKELL__ >= 900 -#else - newAnns = relativiseApiAnns newMN mempty -#endif in pure newMN -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 type DoGenReplacement an ast a = (Data ast, Data a) => a -> @@ -309,17 +207,7 @@ type DoGenReplacement an ast a = LocatedAn an ast -> LocatedAn an ast -> StateT Bool IO (LocatedAn an ast) -#else -type DoGenReplacement ast a = - (Data (SrcSpanLess ast), HasSrcSpan ast, Data a) => - a -> - (ast -> Bool) -> - ast -> - ast -> - StateT ((Anns, AnnKeyMap), Bool) IO ast -#endif -#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900 type ReplaceWorker a mod = (Data a, Data mod) => mod -> @@ -327,80 +215,3 @@ type ReplaceWorker a mod = Int -> Refactoring SrcSpan -> IO mod -#else -type ReplaceWorker a mod = - (Data a, HasSrcSpan a, Data mod, Data (SrcSpanLess a)) => - Anns -> - mod -> - AnnKeyMap -> - Parser a -> - Int -> - Refactoring SrcSpan -> - IO (Anns, mod, AnnKeyMap) -#endif - -#if __GLASGOW_HASKELL__ < 900 --- | Copied from "Language.Haskell.GhclibParserEx.GHC.Driver.Session", in order to --- support GHC 8.6 -impliedXFlags :: [(Extension, Bool, Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (RankNTypes, True, ExplicitForAll) - , (QuantifiedConstraints, True, ExplicitForAll) - , (ScopedTypeVariables, True, ExplicitForAll) - , (LiberalTypeSynonyms, True, ExplicitForAll) - , (ExistentialQuantification, True, ExplicitForAll) - , (FlexibleInstances, True, TypeSynonymInstances) - , (FunctionalDependencies, True, MultiParamTypeClasses) - , (MultiParamTypeClasses, True, ConstrainedClassMethods) -- c.f. #7854 - , (TypeFamilyDependencies, True, TypeFamilies) - - , (RebindableSyntax, False, ImplicitPrelude) -- NB: turn off! - - , (DerivingVia, True, DerivingStrategies) - - , (GADTs, True, GADTSyntax) - , (GADTs, True, MonoLocalBinds) - , (TypeFamilies, True, MonoLocalBinds) - - , (TypeFamilies, True, KindSignatures) -- Type families use kind signatures - , (PolyKinds, True, KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (TypeInType, True, DataKinds) - , (TypeInType, True, PolyKinds) - , (TypeInType, True, KindSignatures) - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (AutoDeriveTypeable, True, DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (TypeFamilies, True, ExplicitNamespaces) - , (TypeOperators, True, ExplicitNamespaces) - - , (ImpredicativeTypes, True, RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (RecordWildCards, True, DisambiguateRecordFields) - - , (ParallelArrays, True, ParallelListComp) - - , (JavaScriptFFI, True, InterruptibleFFI) - - , (DeriveTraversable, True, DeriveFunctor) - , (DeriveTraversable, True, DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (DuplicateRecordFields, True, DisambiguateRecordFields) - - , (TemplateHaskell, True, TemplateHaskellQuotes) - , (Strict, True, StrictData) -#if __GLASGOW_HASKELL__ >= 810 - , (StandaloneKindSignatures, False, CUSKs) -#endif - ] -#endif