{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Test.Tasty.AutoCollect.GHC.Shim_9_2 (
  -- * Re-exports
  module X,

  -- * Compat

  -- ** Plugin
  setKeepRawTokenStream,
  withParsedResultModule,

  -- ** Annotations
  generatedSrcAnn,
  getExportComments,
  toSrcAnnA,

  -- ** SrcSpan
  srcSpanStart,

  -- ** OccName
  mkOccNameVar,
  mkOccNameTC,

  -- ** Decl
  parseDecl,

  -- ** Type
  parseSigWcType,
  parseType,

  -- ** Expr
  mkExplicitList,
  mkExplicitTuple,
  xAppTypeE,

  -- * Backports
  thNameToGhcNameIO,
) where

-- Re-exports
import GHC.Driver.Main as X (getHscEnv)
import GHC.Hs as X hiding (comment, mkHsAppType, mkHsAppTypes)
import GHC.Plugins as X hiding (AnnBind (..), AnnExpr' (..), getHscEnv, showPpr, srcSpanStart, varName)
import GHC.Types.Name.Cache as X (NameCache)

import Data.IORef (IORef)
import qualified Data.Text as Text
import qualified GHC.Types.Name.Occurrence as NameSpace (tcName, varName)
import qualified GHC.Types.SrcLoc as GHC (srcSpanStart)
import qualified Language.Haskell.TH as TH

import Test.Tasty.AutoCollect.GHC.Shim_Common
import Test.Tasty.AutoCollect.Utils.Text

{----- Compat / Plugin -----}

setKeepRawTokenStream :: Plugin -> Plugin
setKeepRawTokenStream :: Plugin -> Plugin
setKeepRawTokenStream Plugin
plugin =
  Plugin
plugin
    { driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv
driverPlugin = \[CommandLineOption]
_ HscEnv
env ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          HscEnv
env
            { hsc_dflags :: DynFlags
hsc_dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_KeepRawTokenStream
            }
    }

withParsedResultModule :: HsParsedModule -> (HsParsedModule -> HsParsedModule) -> HsParsedModule
withParsedResultModule :: HsParsedModule
-> (HsParsedModule -> HsParsedModule) -> HsParsedModule
withParsedResultModule = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)

{----- Compat / Annotations -----}

-- | Get the contents of all comments in the given hsmodExports list.
getExportComments :: HsParsedModule -> LocatedL [LIE GhcPs] -> [RealLocated String]
getExportComments :: HsParsedModule
-> LocatedL [LIE GhcPs] -> [RealLocated CommandLineOption]
getExportComments HsParsedModule
_ = forall a b. (a -> b) -> [a] -> [b]
map GenLocated Anchor EpaComment -> RealLocated CommandLineOption
fromLEpaComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpAnnComments -> [GenLocated Anchor EpaComment]
priorComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall an. EpAnn an -> EpAnnComments
epAnnComments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SrcSpanAnn' a -> a
ann forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc
  where
    fromLEpaComment :: GenLocated Anchor EpaComment -> RealLocated CommandLineOption
fromLEpaComment (L Anchor{RealSrcSpan
anchor :: Anchor -> RealSrcSpan
anchor :: RealSrcSpan
anchor} EpaComment{EpaCommentTok
ac_tok :: EpaComment -> EpaCommentTok
ac_tok :: EpaCommentTok
ac_tok}) =
      forall l e. l -> e -> GenLocated l e
L RealSrcSpan
anchor forall a b. (a -> b) -> a -> b
$ (Text -> CommandLineOption
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpaCommentTok -> Text
unwrap) EpaCommentTok
ac_tok
    unwrap :: EpaCommentTok -> Text
unwrap = \case
      EpaDocCommentNext CommandLineOption
s -> Text -> Text -> Text
withoutPrefix Text
"-- |" forall a b. (a -> b) -> a -> b
$ CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaDocCommentPrev CommandLineOption
s -> Text -> Text -> Text
withoutPrefix Text
"-- ^" forall a b. (a -> b) -> a -> b
$ CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaDocCommentNamed CommandLineOption
s -> Text -> Text -> Text
withoutPrefix Text
"-- $" forall a b. (a -> b) -> a -> b
$ CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaDocSection Int
_ CommandLineOption
s -> CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaDocOptions CommandLineOption
s -> CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaLineComment CommandLineOption
s -> Text -> Text -> Text
withoutPrefix Text
"--" forall a b. (a -> b) -> a -> b
$ CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaBlockComment CommandLineOption
s -> Text -> Text -> Text
withoutPrefix Text
"{-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
withoutSuffix Text
"-}" forall a b. (a -> b) -> a -> b
$ CommandLineOption -> Text
Text.pack CommandLineOption
s
      EpaCommentTok
EpaEofComment -> Text
""

generatedSrcAnn :: SrcAnn ann
generatedSrcAnn :: forall ann. SrcAnn ann
generatedSrcAnn = forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn forall a. EpAnn a
noAnn SrcSpan
generatedSrcSpan

toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA
toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA
toSrcAnnA RealSrcSpan
rss = forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn forall a. EpAnn a
noAnn (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
rss forall a. Maybe a
Nothing)

{----- Compat / SrcSpan -----}

srcSpanStart :: SrcSpan -> Either String RealSrcLoc
srcSpanStart :: SrcSpan -> Either CommandLineOption RealSrcLoc
srcSpanStart SrcSpan
ss =
  case SrcSpan -> SrcLoc
GHC.srcSpanStart SrcSpan
ss of
    RealSrcLoc RealSrcLoc
srcLoc Maybe BufPos
_ -> forall a b. b -> Either a b
Right RealSrcLoc
srcLoc
    UnhelpfulLoc FastString
s -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ FastString -> CommandLineOption
unpackFS FastString
s

{----- Compat / OccName -----}

mkOccNameVar :: String -> OccName
mkOccNameVar :: CommandLineOption -> OccName
mkOccNameVar = NameSpace -> CommandLineOption -> OccName
mkOccName NameSpace
NameSpace.varName

mkOccNameTC :: String -> OccName
mkOccNameTC :: CommandLineOption -> OccName
mkOccNameTC = NameSpace -> CommandLineOption -> OccName
mkOccName NameSpace
NameSpace.tcName

{----- Compat / Decl -----}

parseDecl :: LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl :: LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl (L SrcSpanAnnA
_ HsDecl GhcPs
decl) =
  case HsDecl GhcPs
decl of
    SigD XSigD GhcPs
_ (TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
names LHsSigWcType GhcPs
ty) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [LocatedN RdrName] -> LHsSigWcType GhcPs -> ParsedDecl
FuncSig [LIdP GhcPs]
names LHsSigWcType GhcPs
ty
    ValD XValD GhcPs
_ (FunBind XFunBind GhcPs GhcPs
_ LIdP GhcPs
name MG{mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts = L SrcSpanAnn' (EpAnn AnnList)
_ [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches} [CoreTickish]
_) ->
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> [LocatedA FuncSingleDef] -> ParsedDecl
FuncDef LIdP GhcPs
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> FuncSingleDef
parseFuncSingleDef) [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
matches
    HsDecl GhcPs
_ -> forall a. Maybe a
Nothing
  where
    parseFuncSingleDef :: Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> FuncSingleDef
parseFuncSingleDef Match{[LPat GhcPs]
m_pats :: forall p body. Match p body -> [LPat p]
m_pats :: [LPat GhcPs]
m_pats, m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bodys HsLocalBinds GhcPs
whereClause} =
      FuncSingleDef
        { funcDefArgs :: [LPat GhcPs]
funcDefArgs = [LPat GhcPs]
m_pats
        , funcDefGuards :: [FuncGuardedBody]
funcDefGuards = forall a b. (a -> b) -> [a] -> [b]
map forall {l}.
GenLocated l (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> FuncGuardedBody
parseFuncGuardedBody [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
bodys
        , funcDefWhereClause :: HsLocalBinds GhcPs
funcDefWhereClause = HsLocalBinds GhcPs
whereClause
        }
    parseFuncGuardedBody :: GenLocated l (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> FuncGuardedBody
parseFuncGuardedBody (L l
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [GuardLStmt GhcPs]
guards GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)) =
      [GuardLStmt GhcPs] -> LHsExpr GhcPs -> FuncGuardedBody
FuncGuardedBody [GuardLStmt GhcPs]
guards GenLocated SrcSpanAnnA (HsExpr GhcPs)
body

{----- Compat / Type -----}

parseSigWcType :: LHsSigWcType GhcPs -> Maybe ParsedType
parseSigWcType :: LHsSigWcType GhcPs -> Maybe ParsedType
parseSigWcType (HsWC XHsWC GhcPs (LHsSigType GhcPs)
_ (L SrcSpanAnnA
_ (HsSig XHsSig GhcPs
_ HsOuterSigTyVarBndrs GhcPs
_ LHsType GhcPs
ltype))) = LHsType GhcPs -> Maybe ParsedType
parseType LHsType GhcPs
ltype

parseType :: LHsType GhcPs -> Maybe ParsedType
parseType :: LHsType GhcPs -> Maybe ParsedType
parseType (L SrcSpanAnnA
_ HsType GhcPs
ty) =
  case HsType GhcPs
ty of
    HsTyVar XTyVar GhcPs
_ PromotionFlag
flag LIdP GhcPs
name -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PromotionFlag -> LocatedN RdrName -> ParsedType
TypeVar PromotionFlag
flag LIdP GhcPs
name
    HsListTy XListTy GhcPs
_ LHsType GhcPs
t -> ParsedType -> ParsedType
TypeList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsType GhcPs -> Maybe ParsedType
parseType LHsType GhcPs
t
    HsType GhcPs
_ -> forall a. Maybe a
Nothing

{----- Compat / Expr -----}

mkExplicitList :: [LHsExpr GhcPs] -> HsExpr GhcPs
mkExplicitList :: [LHsExpr GhcPs] -> HsExpr GhcPs
mkExplicitList = forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList forall a. EpAnn a
noAnn

mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
mkExplicitTuple = forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple forall a. EpAnn a
noAnn

xAppTypeE :: XAppTypeE GhcPs
xAppTypeE :: XAppTypeE GhcPs
xAppTypeE = SrcSpan
generatedSrcSpan

{----- Backports -----}

-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8492
thNameToGhcNameIO :: HscEnv -> IORef NameCache -> TH.Name -> IO (Maybe Name)
thNameToGhcNameIO :: HscEnv -> IORef NameCache -> Name -> IO (Maybe Name)
thNameToGhcNameIO HscEnv
hscEnv IORef NameCache
cache Name
name =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM
      HscEnv
hscEnv{hsc_NC :: IORef NameCache
hsc_NC = IORef NameCache
cache}
      (forall {a}. CommandLineOption -> a
unused CommandLineOption
"cr_rule_base")
      (forall {a}. a -> a
strict Char
'.')
      (forall {a}. CommandLineOption -> a
unused CommandLineOption
"cr_module")
      (forall {a}. a -> a
strict forall a. Monoid a => a
mempty)
      (forall {a}. CommandLineOption -> a
unused CommandLineOption
"cr_print_unqual")
      (forall {a}. CommandLineOption -> a
unused CommandLineOption
"cr_loc")
    forall a b. (a -> b) -> a -> b
$ Name -> CoreM (Maybe Name)
thNameToGhcName Name
name
  where
    unused :: CommandLineOption -> a
unused CommandLineOption
msg = forall a. HasCallStack => CommandLineOption -> a
error forall a b. (a -> b) -> a -> b
$ CommandLineOption
"unexpectedly used: " forall a. [a] -> [a] -> [a]
++ CommandLineOption
msg

    -- marks fields that are strict, so we can't use `unused`
    strict :: a -> a
strict = forall {a}. a -> a
id