{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Tasty.AutoCollect.GHC.Shim_9_2 (
module X,
setKeepRawTokenStream,
withParsedResultModule,
generatedSrcAnn,
getExportComments,
toSrcAnnA,
srcSpanStart,
mkOccNameVar,
mkOccNameTC,
parseDecl,
parseSigWcType,
parseType,
mkExplicitList,
mkExplicitTuple,
xAppTypeE,
thNameToGhcNameIO,
) where
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
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
($)
getExportComments :: HsParsedModule -> LocatedL [LIE GhcPs] -> [RealLocated String]
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)
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
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
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
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
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
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
strict :: a -> a
strict = forall {a}. a -> a
id