{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
module Liquid.GHC.API.Extra (
module StableModule
, ApiComment(..)
, apiComments
, apiCommentsParsedSource
, dataConSig
, desugarModuleIO
, fsToUnitId
, isPatErrorAlt
, lookupModSummary
, modInfoLookupNameIO
, moduleInfoTc
, parseModuleIO
, qualifiedNameFS
, relevantModules
, renderWithStyle
, showPprQualified
, showSDocQualified
, strictNothing
, thisPackage
, tyConRealArity
, typecheckModuleIO
) where
import Control.Monad.IO.Class
import Liquid.GHC.API.StableModule as StableModule
import GHC
import Data.Data (Data, gmapQr)
import Data.Generics (extQ)
import Data.Foldable (asum)
import Data.List (foldl', sortOn)
import qualified Data.Map as Map
import qualified Data.Set as S
import GHC.Core as Ghc
import GHC.Core.Coercion as Ghc
import GHC.Core.DataCon as Ghc
import GHC.Core.Make (pAT_ERROR_ID)
import GHC.Core.Type as Ghc hiding (typeKind , isPredTy, extendCvSubst, linear)
import GHC.Data.FastString as Ghc
import qualified GHC.Data.EnumSet as EnumSet
import GHC.Data.Maybe
import qualified GHC.Data.Strict
import GHC.Driver.Env
import GHC.Driver.Main
import GHC.Driver.Session as Ghc
import GHC.Tc.Types
import GHC.Types.Name (isSystemName, nameModule_maybe, occNameFS)
import GHC.Types.SrcLoc as Ghc
import GHC.Types.TypeEnv
import GHC.Types.Unique (getUnique)
import GHC.Types.Unique.FM
import GHC.Unit.Module.Deps as Ghc (Dependencies(dep_direct_mods))
import GHC.Unit.Module.Graph as Ghc
( NodeKey(NodeKey_Module)
, ModNodeKeyWithUid(ModNodeKeyWithUid)
, mgTransDeps
)
import GHC.Unit.Module.ModDetails (md_types)
import GHC.Unit.Module.ModSummary (isBootSummary)
import GHC.Utils.Outputable as Ghc hiding ((<>))
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.Deps (Usage(..))
fsToUnitId :: FastString -> UnitId
fsToUnitId :: FastString -> UnitId
fsToUnitId = GenUnit UnitId -> UnitId
toUnitId (GenUnit UnitId -> UnitId)
-> (FastString -> GenUnit UnitId) -> FastString -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> GenUnit UnitId
fsToUnit
thisPackage :: DynFlags -> UnitId
thisPackage :: DynFlags -> UnitId
thisPackage = DynFlags -> UnitId
homeUnitId_
tyConRealArity :: TyCon -> Int
tyConRealArity :: TyCon -> Int
tyConRealArity TyCon
tc = Int -> Kind -> Int
go Int
0 (TyCon -> Kind
tyConKind TyCon
tc)
where
go :: Int -> Kind -> Int
go :: Int -> Kind -> Int
go !Int
acc Kind
k =
case [Maybe Kind] -> Maybe Kind
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [((FunTyFlag, Kind, Kind, Kind) -> Kind)
-> Maybe (FunTyFlag, Kind, Kind, Kind) -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(FunTyFlag
_, Kind
_, Kind
_, Kind
c) -> Kind
c) (Kind -> Maybe (FunTyFlag, Kind, Kind, Kind)
splitFunTy_maybe Kind
k), ((Id, Kind) -> Kind) -> Maybe (Id, Kind) -> Maybe Kind
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id, Kind) -> Kind
forall a b. (a, b) -> b
snd (Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
k)] of
Maybe Kind
Nothing -> Int
acc
Just Kind
ks -> Int -> Kind -> Int
go (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Kind
ks
getDependenciesModuleNames :: ModuleGraph -> UnitId -> Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames :: ModuleGraph -> UnitId -> Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames ModuleGraph
mg UnitId
unitId Dependencies
deps =
(NodeKey -> Maybe ModuleNameWithIsBoot)
-> [NodeKey] -> [ModuleNameWithIsBoot]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe ModuleNameWithIsBoot
nodeKeyToModuleName ([NodeKey] -> [ModuleNameWithIsBoot])
-> [NodeKey] -> [ModuleNameWithIsBoot]
forall a b. (a -> b) -> a -> b
$ Set NodeKey -> [NodeKey]
forall a. Set a -> [a]
S.toList (Set NodeKey -> [NodeKey]) -> Set NodeKey -> [NodeKey]
forall a b. (a -> b) -> a -> b
$ [Set NodeKey] -> Set NodeKey
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set NodeKey] -> Set NodeKey) -> [Set NodeKey] -> Set NodeKey
forall a b. (a -> b) -> a -> b
$ [Maybe (Set NodeKey)] -> [Set NodeKey]
forall a. [Maybe a] -> [a]
catMaybes
[ NodeKey -> Map NodeKey (Set NodeKey) -> Maybe (Set NodeKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
k Map NodeKey (Set NodeKey)
tdeps
| (UnitId
_, ModuleNameWithIsBoot
m) <- Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a. Set a -> [a]
S.toList (Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)])
-> Set (UnitId, ModuleNameWithIsBoot)
-> [(UnitId, ModuleNameWithIsBoot)]
forall a b. (a -> b) -> a -> b
$ Dependencies -> Set (UnitId, ModuleNameWithIsBoot)
dep_direct_mods Dependencies
deps
, let k :: NodeKey
k = ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid -> NodeKey) -> ModNodeKeyWithUid -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ModuleNameWithIsBoot
m UnitId
unitId
]
where
tdeps :: Map NodeKey (Set NodeKey)
tdeps = ModuleGraph -> Map NodeKey (Set NodeKey)
mgTransDeps ModuleGraph
mg
nodeKeyToModuleName :: NodeKey -> Maybe ModuleNameWithIsBoot
nodeKeyToModuleName (NodeKey_Module (ModNodeKeyWithUid ModuleNameWithIsBoot
m UnitId
_)) = ModuleNameWithIsBoot -> Maybe ModuleNameWithIsBoot
forall a. a -> Maybe a
Just ModuleNameWithIsBoot
m
nodeKeyToModuleName NodeKey
_ = Maybe ModuleNameWithIsBoot
forall a. Maybe a
Nothing
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
dynflags SDoc
sdoc PprStyle
style = SDocContext -> SDoc -> String
Ghc.renderWithContext (DynFlags -> PprStyle -> SDocContext
Ghc.initSDocContext DynFlags
dynflags PprStyle
style) SDoc
sdoc
dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type)
dataConSig :: DataCon -> ([Id], ThetaType, ThetaType, Kind)
dataConSig DataCon
dc
= (DataCon -> [Id]
dataConUnivAndExTyCoVars DataCon
dc, DataCon -> ThetaType
dataConTheta DataCon
dc, (Scaled Kind -> Kind) -> [Scaled Kind] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
irrelevantMult ([Scaled Kind] -> ThetaType) -> [Scaled Kind] -> ThetaType
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Kind]
dataConOrigArgTys DataCon
dc, DataCon -> Kind
dataConOrigResTy DataCon
dc)
relevantModules :: ModuleGraph -> ModGuts -> S.Set Module
relevantModules :: ModuleGraph -> ModGuts -> Set Module
relevantModules ModuleGraph
mg ModGuts
modGuts = Set Module
used Set Module -> Set Module -> Set Module
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Module
dependencies
where
dependencies :: S.Set Module
dependencies :: Set Module
dependencies = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
S.fromList ([Module] -> Set Module) -> [Module] -> Set Module
forall a b. (a -> b) -> a -> b
$ (ModuleNameWithIsBoot -> Module)
-> [ModuleNameWithIsBoot] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> Module
toModule (ModuleName -> Module)
-> (ModuleNameWithIsBoot -> ModuleName)
-> ModuleNameWithIsBoot
-> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod)
([ModuleNameWithIsBoot] -> [Module])
-> (Dependencies -> [ModuleNameWithIsBoot])
-> Dependencies
-> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleNameWithIsBoot -> Bool)
-> [ModuleNameWithIsBoot] -> [ModuleNameWithIsBoot]
forall a. (a -> Bool) -> [a] -> [a]
filter ((IsBootInterface
NotBoot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
==) (IsBootInterface -> Bool)
-> (ModuleNameWithIsBoot -> IsBootInterface)
-> ModuleNameWithIsBoot
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameWithIsBoot -> IsBootInterface
forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot)
([ModuleNameWithIsBoot] -> [ModuleNameWithIsBoot])
-> (Dependencies -> [ModuleNameWithIsBoot])
-> Dependencies
-> [ModuleNameWithIsBoot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraph -> UnitId -> Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames ModuleGraph
mg UnitId
thisUnitId (Dependencies -> [Module]) -> Dependencies -> [Module]
forall a b. (a -> b) -> a -> b
$ Dependencies
deps
deps :: Dependencies
deps :: Dependencies
deps = ModGuts -> Dependencies
mg_deps ModGuts
modGuts
thisModule :: Module
thisModule :: Module
thisModule = ModGuts -> Module
mg_module ModGuts
modGuts
thisUnitId :: UnitId
thisUnitId = Module -> UnitId
moduleUnitId Module
thisModule
toModule :: ModuleName -> Module
toModule :: ModuleName -> Module
toModule = StableModule -> Module
unStableModule (StableModule -> Module)
-> (ModuleName -> StableModule) -> ModuleName -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> ModuleName -> StableModule
mkStableModule UnitId
thisUnitId
used :: S.Set Module
used :: Set Module
used = [Module] -> Set Module
forall a. Ord a => [a] -> Set a
S.fromList ([Module] -> Set Module) -> [Module] -> Set Module
forall a b. (a -> b) -> a -> b
$ ([Module] -> Usage -> [Module]) -> [Module] -> [Usage] -> [Module]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Module] -> Usage -> [Module]
collectUsage [Module]
forall a. Monoid a => a
mempty ([Usage] -> [Module])
-> (ModGuts -> [Usage]) -> ModGuts -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Usage]
mg_usages (ModGuts -> [Module]) -> ModGuts -> [Module]
forall a b. (a -> b) -> a -> b
$ ModGuts
modGuts
where
collectUsage :: [Module] -> Usage -> [Module]
collectUsage :: [Module] -> Usage -> [Module]
collectUsage [Module]
acc = \case
UsagePackageModule { usg_mod :: Usage -> Module
usg_mod = Module
modl } -> Module
modl Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
acc
UsageHomeModule { usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
modName } -> ModuleName -> Module
toModule ModuleName
modName Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
acc
UsageMergedRequirement { usg_mod :: Usage -> Module
usg_mod = Module
modl } -> Module
modl Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: [Module]
acc
Usage
_ -> [Module]
acc
parseModuleIO :: HscEnv -> ModSummary -> IO ParsedModule
parseModuleIO :: HscEnv -> ModSummary -> IO ParsedModule
parseModuleIO HscEnv
hscEnv ModSummary
ms = do
let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hscEnv { hsc_dflags = ms_hspp_opts ms }
HsParsedModule
hpm <- HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env_tmp ModSummary
ms
ParsedModule -> IO ParsedModule
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [String] -> ParsedModule
ParsedModule ModSummary
ms (HsParsedModule -> ParsedSource
hpm_module HsParsedModule
hpm) (HsParsedModule -> [String]
hpm_src_files HsParsedModule
hpm))
data TypecheckedModuleLH = TypecheckedModuleLH {
TypecheckedModuleLH -> ParsedModule
tmlh_parsed_module :: ParsedModule
, TypecheckedModuleLH -> Maybe RenamedSource
tmlh_renamed_source :: Maybe RenamedSource
, TypecheckedModuleLH -> ModSummary
tmlh_mod_summary :: ModSummary
, TypecheckedModuleLH -> TcGblEnv
tmlh_gbl_env :: TcGblEnv
}
typecheckModuleIO :: HscEnv -> ParsedModule -> IO TypecheckedModuleLH
typecheckModuleIO :: HscEnv -> ParsedModule -> IO TypecheckedModuleLH
typecheckModuleIO HscEnv
hscEnv ParsedModule
pmod = do
let ms :: ModSummary
ms = ParsedModule -> ModSummary
pm_mod_summary ParsedModule
pmod
let dynFlags' :: DynFlags
dynFlags' = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms
let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hscEnv { hsc_dflags = dynFlags' { warningFlags = EnumSet.empty } }
(TcGblEnv
tc_gbl_env, Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe (LHsDoc GhcRn))
rn_info)
<- HscEnv
-> ModSummary
-> HsParsedModule
-> IO (TcGblEnv, Maybe RenamedSource)
hscTypecheckRename HscEnv
hsc_env_tmp ModSummary
ms (HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource))
-> HsParsedModule -> IO (TcGblEnv, Maybe RenamedSource)
forall a b. (a -> b) -> a -> b
$
HsParsedModule { hpm_module :: ParsedSource
hpm_module = ParsedModule -> ParsedSource
forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
hpm_src_files :: [String]
hpm_src_files = ParsedModule -> [String]
pm_extra_src_files ParsedModule
pmod }
TypecheckedModuleLH -> IO TypecheckedModuleLH
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TypecheckedModuleLH {
tmlh_parsed_module :: ParsedModule
tmlh_parsed_module = ParsedModule
pmod
, tmlh_renamed_source :: Maybe RenamedSource
tmlh_renamed_source = Maybe RenamedSource
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe (LHsDoc GhcRn))
rn_info
, tmlh_mod_summary :: ModSummary
tmlh_mod_summary = ModSummary
ms
, tmlh_gbl_env :: TcGblEnv
tmlh_gbl_env = TcGblEnv
tc_gbl_env
}
desugarModuleIO :: HscEnv -> ModSummary -> TypecheckedModuleLH -> IO ModGuts
desugarModuleIO :: HscEnv -> ModSummary -> TypecheckedModuleLH -> IO ModGuts
desugarModuleIO HscEnv
hscEnv ModSummary
originalModSum TypecheckedModuleLH
typechecked = do
let modSum :: ModSummary
modSum = ModSummary
originalModSum { ms_hspp_opts = hsc_dflags hscEnv }
let parsedMod' :: ParsedModule
parsedMod' = (TypecheckedModuleLH -> ParsedModule
tmlh_parsed_module TypecheckedModuleLH
typechecked) { pm_mod_summary = modSum }
let typechecked' :: TypecheckedModuleLH
typechecked' = TypecheckedModuleLH
typechecked { tmlh_parsed_module = parsedMod' }
let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hscEnv { hsc_dflags = ms_hspp_opts (tmlh_mod_summary typechecked') }
HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env_tmp (TypecheckedModuleLH -> ModSummary
tmlh_mod_summary TypecheckedModuleLH
typechecked') (TypecheckedModuleLH -> TcGblEnv
tmlh_gbl_env TypecheckedModuleLH
typechecked')
data
= String
| String
deriving (ApiComment -> ApiComment -> Bool
(ApiComment -> ApiComment -> Bool)
-> (ApiComment -> ApiComment -> Bool) -> Eq ApiComment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApiComment -> ApiComment -> Bool
== :: ApiComment -> ApiComment -> Bool
$c/= :: ApiComment -> ApiComment -> Bool
/= :: ApiComment -> ApiComment -> Bool
Eq, Int -> ApiComment -> ShowS
[ApiComment] -> ShowS
ApiComment -> String
(Int -> ApiComment -> ShowS)
-> (ApiComment -> String)
-> ([ApiComment] -> ShowS)
-> Show ApiComment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApiComment -> ShowS
showsPrec :: Int -> ApiComment -> ShowS
$cshow :: ApiComment -> String
show :: ApiComment -> String
$cshowList :: [ApiComment] -> ShowS
showList :: [ApiComment] -> ShowS
Show)
apiComments :: ParsedModule -> [Ghc.Located ApiComment]
ParsedModule
pm = ParsedSource -> [Located ApiComment]
apiCommentsParsedSource (ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm)
apiCommentsParsedSource :: Located (HsModule GhcPs) -> [Ghc.Located ApiComment]
ParsedSource
ps =
let hs :: HsModule GhcPs
hs = ParsedSource -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc ParsedSource
ps
go :: forall a. Data a => a -> [LEpaComment]
go :: forall a. Data a => a -> [LEpaComment]
go = ([LEpaComment] -> [LEpaComment] -> [LEpaComment])
-> [LEpaComment]
-> (forall a. Data a => a -> [LEpaComment])
-> a
-> [LEpaComment]
forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQr [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
(++) [] d -> [LEpaComment]
forall a. Data a => a -> [LEpaComment]
go (a -> [LEpaComment])
-> ([LEpaComment] -> [LEpaComment]) -> a -> [LEpaComment]
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (forall a. a -> a
id @[LEpaComment])
in (Located ApiComment -> Maybe (Int, Int))
-> [Located ApiComment] -> [Located ApiComment]
forall b a. Ord b => (a -> b) -> [a] -> [a]
Data.List.sortOn (SrcSpan -> Maybe (Int, Int)
spanToLineColumn (SrcSpan -> Maybe (Int, Int))
-> (Located ApiComment -> SrcSpan)
-> Located ApiComment
-> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ApiComment -> SrcSpan
forall l e. GenLocated l e -> l
getLoc) ([Located ApiComment] -> [Located ApiComment])
-> [Located ApiComment] -> [Located ApiComment]
forall a b. (a -> b) -> a -> b
$
(LEpaComment -> Maybe (Located ApiComment))
-> [LEpaComment] -> [Located ApiComment]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (GenLocated SrcSpan EpaComment -> Maybe (Located ApiComment)
forall {l}.
GenLocated l EpaComment -> Maybe (GenLocated l ApiComment)
tokComment (GenLocated SrcSpan EpaComment -> Maybe (Located ApiComment))
-> (LEpaComment -> GenLocated SrcSpan EpaComment)
-> LEpaComment
-> Maybe (Located ApiComment)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEpaComment -> GenLocated SrcSpan EpaComment
forall {e}. GenLocated Anchor e -> GenLocated SrcSpan e
toRealSrc) ([LEpaComment] -> [Located ApiComment])
-> [LEpaComment] -> [Located ApiComment]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LEpaComment]
forall a. Data a => a -> [LEpaComment]
go HsModule GhcPs
hs
where
tokComment :: GenLocated l EpaComment -> Maybe (GenLocated l ApiComment)
tokComment (L l
sp (EpaComment (EpaLineComment String
s) RealSrcSpan
_)) = GenLocated l ApiComment -> Maybe (GenLocated l ApiComment)
forall a. a -> Maybe a
Just (l -> ApiComment -> GenLocated l ApiComment
forall l e. l -> e -> GenLocated l e
L l
sp (String -> ApiComment
ApiLineComment String
s))
tokComment (L l
sp (EpaComment (EpaBlockComment String
s) RealSrcSpan
_)) = GenLocated l ApiComment -> Maybe (GenLocated l ApiComment)
forall a. a -> Maybe a
Just (l -> ApiComment -> GenLocated l ApiComment
forall l e. l -> e -> GenLocated l e
L l
sp (String -> ApiComment
ApiBlockComment String
s))
tokComment GenLocated l EpaComment
_ = Maybe (GenLocated l ApiComment)
forall a. Maybe a
Nothing
toRealSrc :: GenLocated Anchor e -> GenLocated SrcSpan e
toRealSrc (L Anchor
a e
e) = SrcSpan -> e -> GenLocated SrcSpan e
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (Anchor -> RealSrcSpan
anchor Anchor
a) Maybe BufSpan
forall a. Maybe a
strictNothing) e
e
spanToLineColumn :: SrcSpan -> Maybe (Int, Int)
spanToLineColumn =
(RealSrcSpan -> (Int, Int))
-> Maybe RealSrcSpan -> Maybe (Int, Int)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RealSrcSpan
s -> (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s)) (Maybe RealSrcSpan -> Maybe (Int, Int))
-> (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan
lookupModSummary :: HscEnv -> ModuleName -> Maybe ModSummary
lookupModSummary :: HscEnv -> ModuleName -> Maybe ModSummary
lookupModSummary HscEnv
hscEnv ModuleName
mdl = do
let mg :: ModuleGraph
mg = HscEnv -> ModuleGraph
hsc_mod_graph HscEnv
hscEnv
mods_by_name :: [ModSummary]
mods_by_name = [ ModSummary
ms | ModSummary
ms <- ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mg
, ModSummary -> ModuleName
ms_mod_name ModSummary
ms ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mdl
, IsBootInterface
NotBoot IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> IsBootInterface
isBootSummary ModSummary
ms ]
case [ModSummary]
mods_by_name of
[ModSummary
ms] -> ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
ms
[ModSummary]
_ -> Maybe ModSummary
forall a. Maybe a
Nothing
newtype ModuleInfoLH = ModuleInfoLH { ModuleInfoLH -> UniqFM Name TyThing
minflh_type_env :: UniqFM Name TyThing }
modInfoLookupNameIO :: HscEnv
-> ModuleInfoLH
-> Name
-> IO (Maybe TyThing)
modInfoLookupNameIO :: HscEnv -> ModuleInfoLH -> Name -> IO (Maybe TyThing)
modInfoLookupNameIO HscEnv
hscEnv ModuleInfoLH
minf Name
name =
case UniqFM Name TyThing -> Name -> Maybe TyThing
lookupTypeEnv (ModuleInfoLH -> UniqFM Name TyThing
minflh_type_env ModuleInfoLH
minf) Name
name of
Just TyThing
tyThing -> Maybe TyThing -> IO (Maybe TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> Maybe TyThing
forall a. a -> Maybe a
Just TyThing
tyThing)
Maybe TyThing
Nothing -> HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hscEnv Name
name
moduleInfoTc :: HscEnv -> TcGblEnv -> IO ModuleInfoLH
moduleInfoTc :: HscEnv -> TcGblEnv -> IO ModuleInfoLH
moduleInfoTc HscEnv
hscEnv TcGblEnv
tcGblEnv = do
UniqFM Name TyThing
details <- ModDetails -> UniqFM Name TyThing
md_types (ModDetails -> UniqFM Name TyThing)
-> IO ModDetails -> IO (UniqFM Name TyThing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ModDetails -> IO ModDetails
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails (HscEnv -> Logger
hsc_logger HscEnv
hscEnv) TcGblEnv
tcGblEnv)
ModuleInfoLH -> IO ModuleInfoLH
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleInfoLH { minflh_type_env :: UniqFM Name TyThing
minflh_type_env = UniqFM Name TyThing
details }
isPatErrorAlt :: CoreAlt -> Bool
isPatErrorAlt :: CoreAlt -> Bool
isPatErrorAlt (Alt AltCon
_ [Id]
_ Expr Id
exprCoreBndr) = Expr Id -> Bool
hasPatErrorCall Expr Id
exprCoreBndr
where
hasPatErrorCall :: CoreExpr -> Bool
hasPatErrorCall :: Expr Id -> Bool
hasPatErrorCall (App (Var Id
x) Expr Id
_) = Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
pAT_ERROR_ID
hasPatErrorCall (Let (NonRec Id
x Expr Id
e) (Case (Var Id
v) Id
_ Kind
_ []))
| Id
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v = Expr Id -> Bool
hasPatErrorCall Expr Id
e
hasPatErrorCall (Let Bind Id
_ Expr Id
e) = Expr Id -> Bool
hasPatErrorCall Expr Id
e
hasPatErrorCall Expr Id
_ = Bool
False
qualifiedNameFS :: Name -> FastString
qualifiedNameFS :: Name -> FastString
qualifiedNameFS Name
n = [FastString] -> FastString
concatFS [FastString
modFS, FastString
occFS, FastString
uniqFS]
where
modFS :: FastString
modFS = case Name -> Maybe Module
nameModule_maybe Name
n of
Maybe Module
Nothing -> String -> FastString
fsLit String
""
Just Module
m -> [FastString] -> FastString
concatFS [ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m), String -> FastString
fsLit String
"."]
occFS :: FastString
occFS = OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
n)
uniqFS :: FastString
uniqFS
| Name -> Bool
isSystemName Name
n
= [FastString] -> FastString
concatFS [String -> FastString
fsLit String
"_", String -> FastString
fsLit (Unique -> String
forall a. Outputable a => a -> String
showPprQualified (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
n))]
| Bool
otherwise
= String -> FastString
fsLit String
""
showPprQualified :: Outputable a => a -> String
showPprQualified :: forall a. Outputable a => a -> String
showPprQualified = SDoc -> String
showSDocQualified (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr
showSDocQualified :: Ghc.SDoc -> String
showSDocQualified :: SDoc -> String
showSDocQualified = SDocContext -> SDoc -> String
Ghc.renderWithContext SDocContext
ctx
where
style :: PprStyle
style = NamePprCtx -> Depth -> PprStyle
Ghc.mkUserStyle NamePprCtx
myQualify Depth
Ghc.AllTheWay
ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext { sdocStyle = style }
myQualify :: Ghc.NamePprCtx
myQualify :: NamePprCtx
myQualify = NamePprCtx
Ghc.neverQualify { Ghc.queryQualifyName = Ghc.alwaysQualifyNames }
strictNothing :: GHC.Data.Strict.Maybe a
strictNothing :: forall a. Maybe a
strictNothing = Maybe a
forall a. Maybe a
GHC.Data.Strict.Nothing