{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}

module Liquid.GHC.API.Extra (
    module StableModule
  , ApiComment(..)
  , apiComments
  , apiCommentsParsedSource
  , dataConSig
  , desugarModuleIO
  , fsToUnitId
  , getDependenciesModuleNames
  , isPatErrorAlt
  , lookupModSummary
  , modInfoLookupNameIO
  , moduleInfoTc
  , moduleUnitId
  , parseModuleIO
  , qualifiedNameFS
  , relevantModules
  , renderWithStyle
  , showPprQualified
  , showSDocQualified
  , 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.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 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_mods))
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> GenUnit UnitId
fsToUnit

moduleUnitId :: Module -> UnitId
moduleUnitId :: Module -> UnitId
moduleUnitId = GenUnit UnitId -> UnitId
toUnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> unit
moduleUnit

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 forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Kind
_, Kind
_, Kind
c) -> Kind
c) (Kind -> Maybe (Kind, Kind, Kind)
splitFunTy_maybe Kind
k), forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 forall a. Num a => a -> a -> a
+ Int
1) Kind
ks

getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames :: Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames = Dependencies -> [ModuleNameWithIsBoot]
dep_mods

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, forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
irrelevantMult 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 :: ModGuts -> S.Set Module
relevantModules :: ModGuts -> Set Module
relevantModules ModGuts
modGuts = Set Module
used forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Module
dependencies
  where
    dependencies :: S.Set Module
    dependencies :: Set Module
dependencies = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> Module
toModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> mod
gwib_mod)
                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((IsBootInterface
NotBoot forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall mod. GenWithIsBoot mod -> IsBootInterface
gwib_isBoot)
                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [ModuleNameWithIsBoot]
getDependenciesModuleNames 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

    toModule :: ModuleName -> Module
    toModule :: ModuleName -> Module
toModule = StableModule -> Module
unStableModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> ModuleName -> StableModule
mkStableModule (Module -> UnitId
moduleUnitId Module
thisModule)

    used :: S.Set Module
    used :: Set Module
used = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Module] -> Usage -> [Module]
collectUsage forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> [Usage]
mg_usages 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 forall a. a -> [a] -> [a]
: [Module]
acc
          UsageHomeModule        { usg_mod_name :: Usage -> ModuleName
usg_mod_name = ModuleName
modName } -> ModuleName -> Module
toModule ModuleName
modName forall a. a -> [a] -> [a]
: [Module]
acc
          UsageMergedRequirement { usg_mod :: Usage -> Module
usg_mod      = Module
modl    } -> Module
modl 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 :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
  HsParsedModule
hpm <- HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env_tmp ModSummary
ms
  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
hsc_dflags = DynFlags
dynFlags' { warningFlags :: EnumSet WarningFlag
warningFlags = forall a. EnumSet a
EnumSet.empty } }
  (TcGblEnv
tc_gbl_env, Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
rn_info)
        <- HscEnv
-> ModSummary
-> HsParsedModule
-> IO (TcGblEnv, Maybe RenamedSource)
hscTypecheckRename HscEnv
hsc_env_tmp ModSummary
ms forall a b. (a -> b) -> a -> b
$
                       HsParsedModule { hpm_module :: ParsedSource
hpm_module = forall m. ParsedMod m => m -> ParsedSource
parsedSource ParsedModule
pmod,
                                        hpm_src_files :: [String]
hpm_src_files = ParsedModule -> [String]
pm_extra_src_files ParsedModule
pmod }
  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
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe LHsDocString)
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 :: DynFlags
ms_hspp_opts = HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv }
  let parsedMod' :: ParsedModule
parsedMod'     = (TypecheckedModuleLH -> ParsedModule
tmlh_parsed_module TypecheckedModuleLH
typechecked) { pm_mod_summary :: ModSummary
pm_mod_summary = ModSummary
modSum }
  let typechecked' :: TypecheckedModuleLH
typechecked'   = TypecheckedModuleLH
typechecked { tmlh_parsed_module :: ParsedModule
tmlh_parsed_module = ParsedModule
parsedMod' }

  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hscEnv { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts (TypecheckedModuleLH -> ModSummary
tmlh_mod_summary TypecheckedModuleLH
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiComment -> ApiComment -> Bool
$c/= :: ApiComment -> ApiComment -> Bool
== :: ApiComment -> ApiComment -> Bool
$c== :: ApiComment -> ApiComment -> Bool
Eq, Int -> ApiComment -> ShowS
[ApiComment] -> ShowS
ApiComment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiComment] -> ShowS
$cshowList :: [ApiComment] -> ShowS
show :: ApiComment -> String
$cshow :: ApiComment -> String
showsPrec :: Int -> ApiComment -> ShowS
$cshowsPrec :: Int -> 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 -> [Ghc.Located ApiComment]
apiCommentsParsedSource :: ParsedSource -> [Located ApiComment]
apiCommentsParsedSource ParsedSource
ps =
    let hs :: HsModule
hs = 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 = forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQr forall a. [a] -> [a] -> [a]
(++) [] forall a. Data a => a -> [LEpaComment]
go forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` (forall a. a -> a
id @[LEpaComment])
     in forall b a. Ord b => (a -> b) -> [a] -> [a]
Data.List.sortOn (SrcSpan -> Maybe (Int, Int)
spanToLineColumn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> l
getLoc) forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {l}.
GenLocated l EpaComment -> Maybe (GenLocated l ApiComment)
tokComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e}. GenLocated Anchor e -> GenLocated SrcSpan e
toRealSrc) forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> [LEpaComment]
go HsModule
hs
  where
    tokComment :: GenLocated l EpaComment -> Maybe (GenLocated l ApiComment)
tokComment (L l
sp (EpaComment (EpaLineComment String
s) RealSrcSpan
_)) = forall a. a -> Maybe a
Just (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
_)) = forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L l
sp (String -> ApiComment
ApiBlockComment String
s))
    tokComment GenLocated l EpaComment
_ = 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) = forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (Anchor -> RealSrcSpan
anchor Anchor
a) forall a. Maybe a
Nothing) e
e

    spanToLineColumn :: SrcSpan -> Maybe (Int, Int)
spanToLineColumn =
      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)) 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 forall a. Eq a => a -> a -> Bool
== ModuleName
mdl
                      , IsBootInterface
NotBoot forall a. Eq a => a -> a -> Bool
== ModSummary -> IsBootInterface
isBootSummary ModSummary
ms ]
   case [ModSummary]
mods_by_name of
     [ModSummary
ms] -> forall a. a -> Maybe a
Just ModSummary
ms
     [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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just TyThing
tyThing)
    Maybe TyThing
Nothing      -> HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hscEnv Name
name

moduleInfoTc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModuleInfoLH
moduleInfoTc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModuleInfoLH
moduleInfoTc HscEnv
hscEnv ModSummary
ms TcGblEnv
tcGblEnv = do
  let hsc_env_tmp :: HscEnv
hsc_env_tmp = HscEnv
hscEnv { hsc_dflags :: DynFlags
hsc_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms }
  UniqFM Name TyThing
details <- ModDetails -> UniqFM Name TyThing
md_types forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env_tmp TcGblEnv
tcGblEnv)
  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 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 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 (forall unit. GenModule unit -> ModuleName
moduleName Module
m), String -> FastString
fsLit String
"."]

  occFS :: FastString
occFS = OccName -> FastString
occNameFS (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 (forall a. Outputable a => a -> String
showPprQualified (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = PrintUnqualified -> Depth -> PprStyle
Ghc.mkUserStyle PrintUnqualified
myQualify Depth
Ghc.AllTheWay
    ctx :: SDocContext
ctx = SDocContext
Ghc.defaultSDocContext { sdocStyle :: PprStyle
sdocStyle = PprStyle
style }

myQualify :: Ghc.PrintUnqualified
myQualify :: PrintUnqualified
myQualify = PrintUnqualified
Ghc.neverQualify { queryQualifyName :: QueryQualifyName
Ghc.queryQualifyName = QueryQualifyName
Ghc.alwaysQualifyNames }
-- { Ghc.queryQualifyName = \_ _ -> Ghc.NameNotInScope1 }