{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternSynonyms #-}

module Refact.Compat (
  -- * ApiAnnotation / GHC.Parser.ApiAnnotation
  AnnKeywordId (..),

  -- * BasicTypes / GHC.Types.Basic
  Fixity (..),
  SourceText (..),

  -- * DynFlags / GHC.Driver.Session
  FlagSpec (..),
  GeneralFlag (..),
  gopt_set,
  gopt_unset,
  parseDynamicFilePragma,
  xopt_set,
  xopt_unset,
  xFlags,

  -- * ErrUtils
  Errors,
  ErrorMessages,
  onError,
  pprErrMsgBagWithLoc,

  -- * FastString / GHC.Data.FastString
  FastString,
  mkFastString,

  -- * HeaderInfo / GHC.Parser.Header
  getOptions,

  -- * HsExpr / GHC.Hs.Expr
  GRHS (..),
  HsExpr (..),
  HsMatchContext (..),
  HsStmtContext (..),
  Match (..),
  MatchGroup (..),
  StmtLR (..),

  -- * HsSyn / GHC.Hs
#if __GLASGOW_HASKELL__ >= 810
  module GHC.Hs,
#else
  module HsSyn,
#endif

  -- * Name / OccName / GHC.Types.Name
  nameOccName,
  occName,
  occNameString,
  ppr,

  -- * Outputable / GHC.Utils.Outputable
  showSDocUnsafe,

  -- * Panic / GHC.Utils.Panic
  handleGhcException,

  -- * RdrName / GHC.Types.Name.Reader
  RdrName (..),
  rdrNameOcc,

  -- * SrcLoc / GHC.Types.SrcLoc
  GenLocated (..),
  pattern RealSrcLoc',
  pattern RealSrcSpan',
  RealSrcSpan (..),
  SrcSpanLess,
  combineSrcSpans,
  composeSrcSpan,
  decomposeSrcSpan,

  -- * StringBuffer
  stringToStringBuffer,

  -- * Misc
  impliedXFlags,

  -- * Non-GHC stuff
  AnnKeyMap,
  FunBind,
  DoGenReplacement,
  Module,
  MonadFail',
  ReplaceWorker,
  annSpanToSrcSpan,
  badAnnSpan,
  mkErr,
  parseModuleName,
  setAnnSpanFile,
  setRealSrcSpanFile,
  setSrcSpanFile,
  srcSpanToAnnSpan,
) where

#if __GLASGOW_HASKELL__ >= 900
import GHC.Data.Bag (unitBag)
import GHC.Data.FastString (FastString, mkFastString)
import GHC.Data.StringBuffer (stringToStringBuffer)
import GHC.Driver.Session hiding (initDynFlags)
import GHC.Parser.Annotation
import GHC.Parser.Header (getOptions)
import GHC.Types.Basic (Fixity (..), SourceText (..))
import GHC.Types.Name (nameOccName, occName, occNameString)
import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc)
import GHC.Types.SrcLoc hiding (spans)
import GHC.Utils.Error
import GHC.Utils.Outputable
  ( ppr,
    showSDocUnsafe,
    pprPanic,
    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 Control.Monad.Trans.State ( StateT )
import Data.Data ( Data )
import Data.Map.Strict (Map)
import qualified GHC
import Language.Haskell.GHC.ExactPrint.Annotate (Annotate)
import Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns )
import Language.Haskell.GHC.ExactPrint.Parsers (Parser)
import Language.Haskell.GHC.ExactPrint.Types
  ( Anns,
    AnnKey (..),
    AnnSpan,
#if __GLASGOW_HASKELL__ >= 900
    badRealSrcSpan,
#endif
  )
import Refact.Types (Refactoring)

#if __GLASGOW_HASKELL__ <= 806
type MonadFail' = Monad
#else
type MonadFail' = MonadFail
#endif

type AnnKeyMap = Map AnnKey [AnnKey]

#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 :: String -> Errors -> a
onError String
s = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
s (SDoc -> a) -> (Errors -> SDoc) -> Errors -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> (Errors -> [SDoc]) -> Errors -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors -> [SDoc]
pprErrMsgBagWithLoc
#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 Nothing
#else
pattern $bRealSrcLoc' :: RealSrcLoc -> SrcLoc
$mRealSrcLoc' :: forall r. SrcLoc -> (RealSrcLoc -> r) -> (Void# -> r) -> r
RealSrcLoc' r <- RealSrcLoc r where
  RealSrcLoc' RealSrcLoc
r = RealSrcLoc -> SrcLoc
RealSrcLoc RealSrcLoc
r
#endif
{-# COMPLETE RealSrcLoc', UnhelpfulLoc #-}

pattern RealSrcSpan' :: RealSrcSpan -> SrcSpan
#if __GLASGOW_HASKELL__ >= 900
pattern RealSrcSpan' r <- RealSrcSpan r _ where
  RealSrcSpan' r = RealSrcSpan r Nothing
#else
pattern $bRealSrcSpan' :: RealSrcSpan -> SrcSpan
$mRealSrcSpan' :: forall r. SrcSpan -> (RealSrcSpan -> r) -> (Void# -> r) -> r
RealSrcSpan' r <- RealSrcSpan r where
  RealSrcSpan' RealSrcSpan
r = RealSrcSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r
#endif
{-# COMPLETE RealSrcSpan', UnhelpfulSpan #-}

#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900
composeSrcSpan :: a -> a
composeSrcSpan = id

decomposeSrcSpan :: a -> a
decomposeSrcSpan = id

type SrcSpanLess a = a
#endif

badAnnSpan :: AnnSpan
badAnnSpan :: SrcSpan
badAnnSpan =
#if __GLASGOW_HASKELL__ >= 900
  badRealSrcSpan
#else
  SrcSpan
noSrcSpan
#endif

srcSpanToAnnSpan :: SrcSpan -> AnnSpan
srcSpanToAnnSpan :: SrcSpan -> SrcSpan
srcSpanToAnnSpan =
#if __GLASGOW_HASKELL__ >= 900
  \case RealSrcSpan l _ -> l; _ -> badRealSrcSpan
#else
  SrcSpan -> SrcSpan
forall a. a -> a
id
#endif

annSpanToSrcSpan :: AnnSpan -> SrcSpan
annSpanToSrcSpan :: SrcSpan -> SrcSpan
annSpanToSrcSpan =
#if __GLASGOW_HASKELL__ >= 900
  flip RealSrcSpan Nothing
#else
  SrcSpan -> SrcSpan
forall a. a -> a
id
#endif

setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan
setSrcSpanFile :: FastString -> SrcSpan -> SrcSpan
setSrcSpanFile FastString
file SrcSpan
s
  | RealSrcLoc' RealSrcLoc
start <- SrcSpan -> SrcLoc
srcSpanStart SrcSpan
s,
    RealSrcLoc' RealSrcLoc
end <- SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
s =
    let start' :: SrcLoc
start' = FastString -> Int -> Int -> SrcLoc
mkSrcLoc FastString
file (RealSrcLoc -> Int
srcLocLine RealSrcLoc
start) (RealSrcLoc -> Int
srcLocCol RealSrcLoc
start)
        end' :: SrcLoc
end' = FastString -> Int -> Int -> SrcLoc
mkSrcLoc FastString
file (RealSrcLoc -> Int
srcLocLine RealSrcLoc
end) (RealSrcLoc -> Int
srcLocCol RealSrcLoc
end)
     in SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
start' SrcLoc
end'
setSrcSpanFile FastString
_ SrcSpan
s = SrcSpan
s

setRealSrcSpanFile :: FastString -> RealSrcSpan -> RealSrcSpan
setRealSrcSpanFile :: FastString -> RealSrcSpan -> RealSrcSpan
setRealSrcSpanFile FastString
file RealSrcSpan
s = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
start' RealSrcLoc
end'
  where
    start :: RealSrcLoc
start = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s
    end :: RealSrcLoc
end = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s
    start' :: RealSrcLoc
start' = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
file (RealSrcLoc -> Int
srcLocLine RealSrcLoc
start) (RealSrcLoc -> Int
srcLocCol RealSrcLoc
start)
    end' :: RealSrcLoc
end' = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
file (RealSrcLoc -> Int
srcLocLine RealSrcLoc
end) (RealSrcLoc -> Int
srcLocCol RealSrcLoc
end)

setAnnSpanFile :: FastString -> AnnSpan -> AnnSpan
setAnnSpanFile :: FastString -> SrcSpan -> SrcSpan
setAnnSpanFile =
#if __GLASGOW_HASKELL__ >= 900
  setRealSrcSpanFile
#else
  FastString -> SrcSpan -> SrcSpan
setSrcSpanFile
#endif

mkErr :: DynFlags -> SrcSpan -> String -> Errors
#if __GLASGOW_HASKELL__ >= 810
mkErr :: DynFlags -> SrcSpan -> String -> Errors
mkErr DynFlags
df SrcSpan
l String
s = ErrMsg -> Errors
forall a. a -> Bag a
unitBag (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
df SrcSpan
l (String -> SDoc
text String
s))
#else
mkErr = const (,)
#endif

parseModuleName :: SrcSpan -> Parser (Located GHC.ModuleName)
parseModuleName :: SrcSpan -> Parser (Located ModuleName)
parseModuleName SrcSpan
ss DynFlags
_ String
_ String
s =
  let newMN :: Located ModuleName
newMN =  SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpan
ss (String -> ModuleName
GHC.mkModuleName String
s)
#if __GLASGOW_HASKELL__ >= 900
      newAnns = relativiseApiAnns newMN (GHC.ApiAnns mempty Nothing mempty mempty)
#else
      newAnns :: Anns
newAnns = Located ModuleName -> ApiAnns -> Anns
forall ast.
(Data (SrcSpanLess ast), Annotate ast, HasSrcSpan ast) =>
ast -> ApiAnns -> Anns
relativiseApiAnns Located ModuleName
newMN ApiAnns
forall a. Monoid a => a
mempty
#endif
  in (Anns, Located ModuleName)
-> Either Errors (Anns, Located ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Anns
newAnns, Located ModuleName
newMN)

#if __GLASGOW_HASKELL__ <= 806 || __GLASGOW_HASKELL__ >= 900
type DoGenReplacement ast a =
  (Data ast, Data a) =>
  a ->
  (Located ast -> Bool) ->
  Located ast ->
  Located ast ->
  StateT ((Anns, AnnKeyMap), Bool) IO (Located 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 =
  (Annotate a, Data mod) =>
  Anns ->
  mod ->
  AnnKeyMap ->
  Parser (Located a) ->
  Int ->
  Refactoring SrcSpan ->
  IO (Anns, mod, AnnKeyMap)
#else
type ReplaceWorker a mod =
  (Annotate 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 :: [(Extension, Bool, Extension)]
impliedXFlags
-- See Note [Updating flag description in the User's Guide]
  = [ (Extension
RankNTypes,                Bool
True, Extension
ExplicitForAll)
    , (Extension
QuantifiedConstraints,     Bool
True, Extension
ExplicitForAll)
    , (Extension
ScopedTypeVariables,       Bool
True, Extension
ExplicitForAll)
    , (Extension
LiberalTypeSynonyms,       Bool
True, Extension
ExplicitForAll)
    , (Extension
ExistentialQuantification, Bool
True, Extension
ExplicitForAll)
    , (Extension
FlexibleInstances,         Bool
True, Extension
TypeSynonymInstances)
    , (Extension
FunctionalDependencies,    Bool
True, Extension
MultiParamTypeClasses)
    , (Extension
MultiParamTypeClasses,     Bool
True, Extension
ConstrainedClassMethods)  -- c.f. #7854
    , (Extension
TypeFamilyDependencies,    Bool
True, Extension
TypeFamilies)

    , (Extension
RebindableSyntax, Bool
False, Extension
ImplicitPrelude)      -- NB: turn off!

    , (Extension
DerivingVia, Bool
True, Extension
DerivingStrategies)

    , (Extension
GADTs,            Bool
True, Extension
GADTSyntax)
    , (Extension
GADTs,            Bool
True, Extension
MonoLocalBinds)
    , (Extension
TypeFamilies,     Bool
True, Extension
MonoLocalBinds)

    , (Extension
TypeFamilies,     Bool
True, Extension
KindSignatures)  -- Type families use kind signatures
    , (Extension
PolyKinds,        Bool
True, Extension
KindSignatures)  -- Ditto polymorphic kinds

    -- TypeInType is now just a synonym for a couple of other extensions.
    , (Extension
TypeInType,       Bool
True, Extension
DataKinds)
    , (Extension
TypeInType,       Bool
True, Extension
PolyKinds)
    , (Extension
TypeInType,       Bool
True, Extension
KindSignatures)

    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable
    , (Extension
AutoDeriveTypeable, Bool
True, Extension
DeriveDataTypeable)

    -- We turn this on so that we can export associated type
    -- type synonyms in subordinates (e.g. MyClass(type AssocType))
    , (Extension
TypeFamilies,     Bool
True, Extension
ExplicitNamespaces)
    , (Extension
TypeOperators, Bool
True, Extension
ExplicitNamespaces)

    , (Extension
ImpredicativeTypes,  Bool
True, Extension
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'
    , (Extension
RecordWildCards,     Bool
True, Extension
DisambiguateRecordFields)

    , (Extension
ParallelArrays, Bool
True, Extension
ParallelListComp)

    , (Extension
JavaScriptFFI, Bool
True, Extension
InterruptibleFFI)

    , (Extension
DeriveTraversable, Bool
True, Extension
DeriveFunctor)
    , (Extension
DeriveTraversable, Bool
True, Extension
DeriveFoldable)

    -- Duplicate record fields require field disambiguation
    , (Extension
DuplicateRecordFields, Bool
True, Extension
DisambiguateRecordFields)

    , (Extension
TemplateHaskell, Bool
True, Extension
TemplateHaskellQuotes)
    , (Extension
Strict, Bool
True, Extension
StrictData)
#if __GLASGOW_HASKELL__ >= 810
    , (Extension
StandaloneKindSignatures, Bool
False, Extension
CUSKs)
#endif
  ]
#endif