{-# 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' is gone in GHC 9, but we can bring code it in terms of 'fsToUnit' and 'toUnitId'.
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_

-- See NOTE [tyConRealArity].
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

-- This function is gone in GHC 9.
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)

-- | The collection of dependencies and usages modules which are relevant for liquidHaskell
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

--
-- Parsing, typechecking and desugaring a module
--
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))

-- | Our own simplified version of 'TypecheckedModule'.
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
  -- Suppress all the warnings, so that they won't be printed (which would result in them being
  -- printed twice, one by GHC and once here).
  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
    }

-- | Desugar a typechecked module.
desugarModuleIO :: HscEnv -> ModSummary -> TypecheckedModuleLH -> IO ModGuts
desugarModuleIO :: HscEnv -> ModSummary -> TypecheckedModuleLH -> IO ModGuts
desugarModuleIO HscEnv
hscEnv ModSummary
originalModSum TypecheckedModuleLH
typechecked = do
  -- See [NOTE:ghc810] on why we override the dynFlags here before calling 'desugarModule'.
  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')

-- | Abstraction of 'EpaComment'.
data ApiComment
  = ApiLineComment String
  | ApiBlockComment 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)

-- | Extract top-level comments from a module.
apiComments :: ParsedModule -> [Ghc.Located ApiComment]
apiComments :: ParsedModule -> [Located ApiComment]
apiComments ParsedModule
pm = ParsedSource -> [Located ApiComment]
apiCommentsParsedSource (ParsedModule -> ParsedSource
pm_parsed_source ParsedModule
pm)

apiCommentsParsedSource :: Located (HsModule GhcPs) -> [Ghc.Located ApiComment]
apiCommentsParsedSource :: ParsedSource -> [Located ApiComment]
apiCommentsParsedSource 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

    -- TODO: take into account anchor_op, which only matters if the source was
    -- pre-processed by an exact-print-aware tool.
    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

-- | Our own simplified version of 'ModuleInfo' to overcome the fact we cannot construct the \"original\"
-- one as the constructor is not exported, and 'getHomeModuleInfo' and 'getPackageModuleInfo' are not
-- exported either, so we had to backport them as well.
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 }

-- | Tells if a case alternative calls to patError
isPatErrorAlt :: CoreAlt -> Bool
isPatErrorAlt :: CoreAlt -> Bool
isPatErrorAlt (Alt AltCon
_ [Id]
_ Expr Id
exprCoreBndr) = Expr Id -> Bool
hasPatErrorCall Expr Id
exprCoreBndr
  where
   hasPatErrorCall :: CoreExpr -> Bool
   -- auto generated undefined case: (\_ -> (patError @levity @type "error message")) void
   -- Type arguments are erased before calling isUndefined
   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
   -- another auto generated undefined case:
   -- let lqanf_... = patError "error message") in case lqanf_... of {}
   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
   -- otherwise
   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
""

-- Variants of Outputable functions which now require DynFlags!
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 }
-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }


strictNothing :: GHC.Data.Strict.Maybe a
strictNothing :: forall a. Maybe a
strictNothing = Maybe a
forall a. Maybe a
GHC.Data.Strict.Nothing