{-# LANGUAGE CPP #-}
module Pollock.CompatGHC
( readIORef
, TcGblEnv
( tcg_exports
, tcg_insts
, tcg_fam_insts
, tcg_warns
, tcg_th_docs
, tcg_semantic_mod
, tcg_rdr_env
, tcg_rn_imports
, tcg_rn_decls
, tcg_rn_exports
)
, getSrcSpan
, nameIsLocalOrFrom
, emptyOccEnv
, lookupNameEnv
, GlobalRdrEnv
, Warnings
, WarningTxt
, declTypeDocs
, extractTHDocs
, getInstLoc
, getMainDeclBinder
, isValD
, nubByName
, subordinates
, topDecls
, DynFlags (generalFlags)
, GenLocated (L)
, HsDocString
, Name
, renderHsDocString
, GhcRn
, IdP
, LHsDecl
, Module
, HsDecl (InstD, DerivD, ValD, SigD, DocD)
, feqn_tycon
, InstDecl
( TyFamInstD
)
, TyFamInstDecl (TyFamInstDecl)
, ModuleName
, SrcSpanAnnA
, collectHsBindBinders
, getLocA
, nameModule
, ExtractedTHDocs (ExtractedTHDocs, ethd_mod_header)
, HsDoc
, WithHsDocIdentifiers (hsDocString)
, IE (IEModuleContents, IEGroup, IEDoc, IEDocNamed)
, ImportDecl
, ideclName
, ideclAs
, ideclImportList
, ImportListInterpretation (Exactly, EverythingBut)
, CollectFlag (CollNoDictBinders)
, RealSrcSpan
, SrcSpan (RealSrcSpan)
, DocDecl (DocCommentNamed, DocGroup)
, Located
, HscEnv (hsc_dflags)
, GeneralFlag (Opt_Haddock)
, lookupSrcSpan
, getName
, unLoc
, AvailInfo
, Avails
, availExportsDecl
, availName
, availNames
, availSubordinateNames
, availsToNameEnv
, nubAvails
, StringLiteral
, processWarnSome
, mapWarningTxtMsg
, getHeaderInfo
, nonDetEltUniqMapToMap
, insertEnumSet
, stringLiteralToString
) where
import qualified Control.Arrow as Arrow
import qualified Control.Monad as M
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.Tc.Types as TcTypes
import qualified GHC.Types.Unique.Map as UniqMap
import GHC
( CollectFlag (CollNoDictBinders)
, DocDecl (DocCommentNamed, DocGroup)
, DynFlags (generalFlags)
, ExtractedTHDocs (ExtractedTHDocs, ethd_mod_header)
, FamEqn (feqn_tycon)
, GenLocated (L)
, GeneralFlag (Opt_Haddock)
, GhcRn
, HsDecl (DerivD, DocD, InstD, SigD, ValD)
, HsDoc
, HsDocString
, HscEnv
, IE (IEDoc, IEDocNamed, IEGroup, IEModuleContents)
, IdP
, InstDecl (TyFamInstD)
, LHsDecl
, Located
, Module
, ModuleName
, Name
, NamedThing (getName)
, RealSrcSpan
, SrcSpan (RealSrcSpan)
, SrcSpanAnnA
, TyFamInstDecl (TyFamInstDecl)
, WithHsDocIdentifiers (hsDocString)
, collectHsBindBinders
, getLocA
, nameModule
, renderHsDocString
, unLoc
)
import GHC.HsToCore.Docs
( declTypeDocs
, extractTHDocs
, getInstLoc
, getMainDeclBinder
, isValD
, nubByName
, subordinates
, topDecls
)
import GHC.IORef (readIORef)
import GHC.Plugins
( GlobalRdrElt
, GlobalRdrEnv
, HscEnv (hsc_dflags)
, OccEnv
, OccName
, emptyOccEnv
, getSrcSpan
, lookupNameEnv
, lookupOccEnv
, lookupSrcSpan
, nameIsLocalOrFrom
, unpackFS
)
import GHC.Tc.Types
( TcGblEnv
( tcg_exports
, tcg_fam_insts
, tcg_insts
, tcg_rdr_env
, tcg_rn_decls
, tcg_rn_exports
, tcg_rn_imports
, tcg_semantic_mod
, tcg_th_docs
, tcg_warns
)
)
import GHC.Types.SourceText (StringLiteral, sl_fs)
import GHC.Unit.Module.Warnings (WarningTxt (DeprecatedTxt, WarningTxt), Warnings (WarnSome))
#if __GLASGOW_HASKELL__ == 910
import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut))
import GHC.Plugins (GlobalRdrEltX, greName)
import qualified GHC.Parser.Annotation as Annotation
import GHC.Types.Avail
( AvailInfo
, Avails
, availExportsDecl
, availName
, availNames
, availSubordinateNames
, availsToNameEnv
, nubAvails
)
import GHC.Types.Unique.Map (nonDetUniqMapToList)
#elif __GLASGOW_HASKELL__ == 908
import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut))
import GHC.Plugins (GlobalRdrEltX, greName)
import GHC.Types.Avail
( AvailInfo
, Avails
, availExportsDecl
, availName
, availNames
, availSubordinateNames
, availsToNameEnv
, nubAvails
)
import GHC.Types.Unique.Map (nonDetUniqMapToList)
#elif __GLASGOW_HASKELL__ == 906
import GHC (ImportDecl, ideclImportList, ideclAs, ideclName, ImportListInterpretation (Exactly, EverythingBut))
import GHC.Plugins (greMangledName)
import GHC.Types.Avail
( AvailInfo
, Avails
, availExportsDecl
, availName
, availNames
, availSubordinateGreNames
, availsToNameEnv
, greNameMangledName
, nubAvails
)
#elif __GLASGOW_HASKELL__ == 904
import GHC (ImportDecl(ideclHiding, ideclAs, ideclName), XRec)
import GHC.Plugins (greMangledName)
import GHC.Types.Avail
( AvailInfo
, Avails
, availExportsDecl
, availName
, availNamesWithSelectors
, availSubordinateGreNames
, availsToNameEnv
, greNameMangledName
, nubAvails
)
#endif
#if __GLASGOW_HASKELL__ == 910
getHeaderInfo :: TcGblEnv -> Maybe HsDocString
getHeaderInfo = fmap (hsDocString . unLoc) . fst . TcTypes.tcg_hdr_info
lookupOccName :: OccEnv [GlobalRdrEltX info] -> OccName -> [Name]
lookupOccName env = fmap greName . lookupOcc env
processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome warnings gre names =
case warnings of
WarnSome ws exports ->
let
keepByName :: [(Name,b)] -> [(Name,b)]
keepByName = filter (\x -> (fst x) `elem` names)
keepOnlyKnownNameWarnings = keepByName . mappend exports . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre))
explodeSnd :: Functor f => (f a, b) -> f (a, b)
explodeSnd (as,b) = fmap ((flip (,) b)) as
in
keepOnlyKnownNameWarnings ws
_ ->
mempty
mapWarningTxtMsg :: ([Annotation.LocatedE
(WithHsDocIdentifiers StringLiteral pass)] -> t)
-> ([Annotation.LocatedE
(WithHsDocIdentifiers StringLiteral pass)] -> t)
-> WarningTxt pass
-> t
mapWarningTxtMsg deprecatedFn warnFn warnTxt =
case warnTxt of
DeprecatedTxt _ msgs -> deprecatedFn msgs
WarningTxt _ _ msgs -> warnFn msgs
#elif __GLASGOW_HASKELL__ == 908
getHeaderInfo :: TcGblEnv -> Maybe HsDocString
getHeaderInfo = fmap (hsDocString . unLoc) . TcTypes.tcg_doc_hdr
lookupOccName :: OccEnv [GlobalRdrEltX info] -> OccName -> [Name]
lookupOccName env = fmap greName . lookupOcc env
processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome warnings gre names =
case warnings of
WarnSome ws exports ->
let
keepByName :: [(Name,b)] -> [(Name,b)]
keepByName = filter (\x -> (fst x) `elem` names)
keepOnlyKnownNameWarnings = keepByName . mappend exports . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre))
explodeSnd :: Functor f => (f a, b) -> f (a, b)
explodeSnd (as,b) = fmap ((flip (,) b)) as
in
keepOnlyKnownNameWarnings ws
_ ->
mempty
mapWarningTxtMsg ::
([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> WarningTxt pass
-> t
mapWarningTxtMsg deprecatedFn warnFn warnTxt =
case warnTxt of
DeprecatedTxt _ msgs -> deprecatedFn msgs
WarningTxt _ _ msgs -> warnFn msgs
#elif __GLASGOW_HASKELL__ == 906
getHeaderInfo :: TcGblEnv -> Maybe HsDocString
= (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn)
-> HsDocString)
-> Maybe
(GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn))
-> Maybe HsDocString
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WithHsDocIdentifiers HsDocString GhcRn -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers HsDocString GhcRn -> HsDocString)
-> (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn)
-> WithHsDocIdentifiers HsDocString GhcRn)
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn)
-> HsDocString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn)
-> WithHsDocIdentifiers HsDocString GhcRn
forall l e. GenLocated l e -> e
unLoc) (Maybe
(GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn))
-> Maybe HsDocString)
-> (TcGblEnv
-> Maybe
(GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn)))
-> TcGblEnv
-> Maybe HsDocString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcGblEnv
-> Maybe
(GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcRn))
TcTypes.tcg_doc_hdr
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames = (GreName -> Name) -> [GreName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GreName -> Name
greNameMangledName ([GreName] -> [Name])
-> (AvailInfo -> [GreName]) -> AvailInfo -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AvailInfo -> [GreName]
availSubordinateGreNames
lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName OccEnv [GlobalRdrElt]
env = (GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlobalRdrElt -> Name
greMangledName ([GlobalRdrElt] -> [Name])
-> (OccName -> [GlobalRdrElt]) -> OccName -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccEnv [GlobalRdrElt] -> OccName -> [GlobalRdrElt]
forall a. OccEnv [a] -> OccName -> [a]
lookupOcc OccEnv [GlobalRdrElt]
env
processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome :: forall pass.
Warnings pass
-> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome Warnings pass
warnings OccEnv [GlobalRdrElt]
gre [Name]
names =
case Warnings pass
warnings of
WarnSome [(OccName, WarningTxt pass)]
ws ->
let
keepByName :: [(Name,b)] -> [(Name,b)]
keepByName :: forall b. [(Name, b)] -> [(Name, b)]
keepByName = ((Name, b) -> Bool) -> [(Name, b)] -> [(Name, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name, b)
x -> ((Name, b) -> Name
forall a b. (a, b) -> a
fst (Name, b)
x) Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names)
keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)]
keepOnlyKnownNameWarnings :: forall b. [(OccName, b)] -> [(Name, b)]
keepOnlyKnownNameWarnings = [(Name, b)] -> [(Name, b)]
forall b. [(Name, b)] -> [(Name, b)]
keepByName ([(Name, b)] -> [(Name, b)])
-> ([(OccName, b)] -> [(Name, b)]) -> [(OccName, b)] -> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, b)]] -> [(Name, b)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
M.join ([[(Name, b)]] -> [(Name, b)])
-> ([(OccName, b)] -> [[(Name, b)]])
-> [(OccName, b)]
-> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((OccName, b) -> [(Name, b)]) -> [(OccName, b)] -> [[(Name, b)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Name], b) -> [(Name, b)]
forall (f :: * -> *) a b. Functor f => (f a, b) -> f (a, b)
explodeSnd (([Name], b) -> [(Name, b)])
-> ((OccName, b) -> ([Name], b)) -> (OccName, b) -> [(Name, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OccName -> [Name]) -> (OccName, b) -> ([Name], b)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first (OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName OccEnv [GlobalRdrElt]
gre))
explodeSnd :: Functor f => (f a, b) -> f (a, b)
explodeSnd :: forall (f :: * -> *) a b. Functor f => (f a, b) -> f (a, b)
explodeSnd (f a
as,b
b) = (a -> (a, b)) -> f a -> f (a, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a -> b -> (a, b)) -> b -> a -> (a, b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
b)) f a
as
in
[(OccName, WarningTxt pass)] -> [(Name, WarningTxt pass)]
forall b. [(OccName, b)] -> [(Name, b)]
keepOnlyKnownNameWarnings [(OccName, WarningTxt pass)]
ws
Warnings pass
_ ->
[(Name, WarningTxt pass)]
forall a. Monoid a => a
mempty
nonDetUniqMapToList :: UniqMap.UniqMap k a -> [(k, a)]
nonDetUniqMapToList :: forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList = UniqMap k a -> [(k, a)]
forall k a. UniqMap k a -> [(k, a)]
UniqMap.nonDetEltsUniqMap
mapWarningTxtMsg ::
([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> WarningTxt pass
-> t
mapWarningTxtMsg :: forall pass t.
([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> WarningTxt pass
-> t
mapWarningTxtMsg [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
deprecatedFn [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
warnFn WarningTxt pass
warnTxt =
case WarningTxt pass
warnTxt of
DeprecatedTxt Located SourceText
_ [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs -> [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
deprecatedFn [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs
WarningTxt Located SourceText
_ [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs -> [Located (WithHsDocIdentifiers StringLiteral pass)] -> t
warnFn [Located (WithHsDocIdentifiers StringLiteral pass)]
msgs
#elif __GLASGOW_HASKELL__ == 904
getHeaderInfo :: TcGblEnv -> Maybe HsDocString
getHeaderInfo = fmap (hsDocString . unLoc) . TcTypes.tcg_doc_hdr
data ImportListInterpretation = Exactly | EverythingBut
ideclImportList :: ImportDecl pass -> Maybe (ImportListInterpretation, XRec pass [XRec pass (IE pass)])
ideclImportList idecl =
case ideclHiding idecl of
Nothing -> Nothing
Just (True, n) -> Just (EverythingBut,n)
Just (False,n) -> Just (Exactly,n)
availNames :: AvailInfo -> [Name]
availNames = availNamesWithSelectors
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames = fmap greNameMangledName . availSubordinateGreNames
lookupOccName :: OccEnv [GlobalRdrElt] -> OccName -> [Name]
lookupOccName env = fmap greMangledName . lookupOcc env
processWarnSome :: Warnings pass -> OccEnv [GlobalRdrElt] -> [Name] -> [(Name, WarningTxt pass)]
processWarnSome warnings gre names =
case warnings of
WarnSome ws ->
let
keepByName :: [(Name,b)] -> [(Name,b)]
keepByName = filter (\x -> fst x `elem` names)
keepOnlyKnownNameWarnings :: [(OccName, b)] -> [(Name, b)]
keepOnlyKnownNameWarnings = keepByName . M.join . fmap (explodeSnd . Arrow.first (lookupOccName gre))
explodeSnd :: Functor f => (f a, b) -> f (a, b)
explodeSnd (as,b) = fmap ((flip (,) b)) as
in
keepOnlyKnownNameWarnings ws
_ ->
mempty
nonDetUniqMapToList :: UniqMap.UniqMap k a -> [(k, a)]
nonDetUniqMapToList = UniqMap.nonDetEltsUniqMap
mapWarningTxtMsg ::
([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> ([Located (WithHsDocIdentifiers StringLiteral pass)] -> t)
-> WarningTxt pass
-> t
mapWarningTxtMsg deprecatedFn warnFn warnTxt =
case warnTxt of
DeprecatedTxt _ msgs -> deprecatedFn msgs
WarningTxt _ msgs -> warnFn msgs
#endif
lookupOcc :: OccEnv [a] -> OccName -> [a]
lookupOcc :: forall a. OccEnv [a] -> OccName -> [a]
lookupOcc OccEnv [a]
env =
[a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
Maybe.fromMaybe [a]
forall a. Monoid a => a
mempty (Maybe [a] -> [a]) -> (OccName -> Maybe [a]) -> OccName -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccEnv [a] -> OccName -> Maybe [a]
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv [a]
env
nonDetEltUniqMapToMap :: (Ord k) => UniqMap.UniqMap k a -> Map.Map k a
nonDetEltUniqMapToMap :: forall k a. Ord k => UniqMap k a -> Map k a
nonDetEltUniqMapToMap = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, a)] -> Map k a)
-> (UniqMap k a -> [(k, a)]) -> UniqMap k a -> Map k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqMap k a -> [(k, a)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList
insertEnumSet :: (Enum a) => a -> EnumSet.EnumSet a -> EnumSet.EnumSet a
insertEnumSet :: forall a. Enum a => a -> EnumSet a -> EnumSet a
insertEnumSet = a -> EnumSet a -> EnumSet a
forall a. Enum a => a -> EnumSet a -> EnumSet a
EnumSet.insert
stringLiteralToString :: StringLiteral -> String
stringLiteralToString :: StringLiteral -> String
stringLiteralToString = FastString -> String
unpackFS (FastString -> String)
-> (StringLiteral -> FastString) -> StringLiteral -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringLiteral -> FastString
sl_fs