module GHC.Types.Name.Ppr
   ( mkNamePprCtx
   , mkQualModule
   , mkQualPackage
   , pkgQual
   )
where

import GHC.Prelude
import GHC.Data.FastString

import GHC.Unit
import GHC.Unit.Env

import GHC.Types.Name
import GHC.Types.Name.Reader


import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Builtin.Types.Prim ( fUNTyConName )
import GHC.Builtin.Types


{-
Note [Printing original names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Deciding how to print names is pretty tricky.  We are given a name
P:M.T, where P is the package name, M is the defining module, and T is
the occurrence name, and we have to decide in which form to display
the name given a GlobalRdrEnv describing the current scope.

Ideally we want to display the name in the form in which it is in
scope.  However, the name might not be in scope at all, and that's
where it gets tricky.  Here are the cases:

 1. T uniquely maps to  P:M.T      --->  "T"      NameUnqual
 2. There is an X for which X.T
       uniquely maps to  P:M.T     --->  "X.T"    NameQual X
 3. There is no binding for "M.T"  --->  "M.T"    NameNotInScope1
 4. Otherwise                      --->  "P:M.T"  NameNotInScope2

(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at
all. In these cases we still want to refer to the name as "M.T", *but*
"M.T" might mean something else in the current scope (e.g. if there's
an "import X as M"), so to avoid confusion we avoid using "M.T" if
there's already a binding for it.  Instead we write P:M.T.

There's one further subtlety: in case (3), what if there are two
things around, P1:M.T and P2:M.T?  Then we don't want to print both of
them as M.T!  However only one of the modules P1:M and P2:M can be
exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
This is handled by the qual_mod component of NamePprCtx, inside
the (ppr mod) of case (3), in Name.pprModulePrefix

Note [Printing unit ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the old days, original names were tied to PackageIds, which directly
corresponded to the entities that users wrote in Cabal files, and were perfectly
suitable for printing when we need to disambiguate packages.  However, with
instantiated units, the situation can be different: if the key is instantiated
with some holes, we should try to give the user some more useful information.
-}

-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc UnitEnv
unit_env GlobalRdrEnv
env
 = QueryQualifyName
-> QueryQualifyModule
-> QueryQualifyPackage
-> QueryPromotionTick
-> NamePprCtx
QueryQualify
      (GlobalRdrEnv -> QueryQualifyName
mkQualName GlobalRdrEnv
env)
      (UnitState -> Maybe HomeUnit -> QueryQualifyModule
mkQualModule UnitState
unit_state Maybe HomeUnit
home_unit)
      (UnitState -> QueryQualifyPackage
mkQualPackage UnitState
unit_state)
      (PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick
mkPromTick PromotionTickContext
ptc GlobalRdrEnv
env)
  where
  unit_state :: UnitState
unit_state = (() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env
  home_unit :: Maybe HomeUnit
home_unit  = UnitEnv -> Maybe HomeUnit
ue_homeUnit UnitEnv
unit_env

mkQualName :: GlobalRdrEnv -> QueryQualifyName
mkQualName :: GlobalRdrEnv -> QueryQualifyName
mkQualName GlobalRdrEnv
env = QueryQualifyName
qual_name where
  qual_name :: QueryQualifyName
qual_name Module
mod OccName
occ
        | [GlobalRdrElt
gre] <- [GlobalRdrElt]
unqual_gres
        , GlobalRdrElt -> Bool
right_name GlobalRdrElt
gre
        = QualifyName
NameUnqual   -- If there's a unique entity that's in scope
                       -- unqualified with 'occ' AND that entity is
                       -- the right one, then we can use the unqualified name

        | [] <- [GlobalRdrElt]
unqual_gres
        , Bool
pretendNameIsInScopeForPpr
        , Bool -> Bool
not (OccName -> Bool
isDerivedOccName OccName
occ)
        = QualifyName
NameUnqual   -- See Note [pretendNameIsInScopeForPpr]

        | [GlobalRdrElt
gre] <- [GlobalRdrElt]
qual_gres
        = ModuleName -> QualifyName
NameQual (GlobalRdrElt -> ModuleName
greQualModName GlobalRdrElt
gre)

        | [GlobalRdrElt] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GlobalRdrElt]
qual_gres
        = if [GlobalRdrElt] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (ModuleName -> OccName -> RdrName
mkRdrQual (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod) OccName
occ) GlobalRdrEnv
env)
          then QualifyName
NameNotInScope1
          else QualifyName
NameNotInScope2

        | Bool
otherwise
        = QualifyName
NameNotInScope1   -- Can happen if 'f' is bound twice in the module
                            -- Eg  f = True; g = 0; f = False
      where
        is_name :: Name -> Bool
        is_name :: Name -> Bool
is_name Name
name = Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
                       (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
name Module -> QueryQualifyModule
forall a. Eq a => a -> a -> Bool
== Module
mod Bool -> Bool -> Bool
&& Name -> OccName
nameOccName Name
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
occ

        -- See Note [pretendNameIsInScopeForPpr]
        pretendNameIsInScopeForPpr :: Bool
        pretendNameIsInScopeForPpr :: Bool
pretendNameIsInScopeForPpr =
          (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Name -> Bool
is_name
            [ Name
liftedTypeKindTyConName
            , Name
constraintKindTyConName
            , Name
heqTyConName
            , Name
coercibleTyConName
            , Name
eqTyConName
            , Name
tYPETyConName
            , Name
fUNTyConName, Name
unrestrictedFunTyConName
            , Name
oneDataConName
            , Name
manyDataConName ]

        right_name :: GlobalRdrElt -> Bool
right_name GlobalRdrElt
gre = GlobalRdrElt -> Maybe Module
greDefinitionModule GlobalRdrElt
gre Maybe Module -> Maybe Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> Maybe Module
forall a. a -> Maybe a
Just Module
mod

        unqual_gres :: [GlobalRdrElt]
unqual_gres = RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (OccName -> RdrName
mkRdrUnqual OccName
occ) GlobalRdrEnv
env
        qual_gres :: [GlobalRdrElt]
qual_gres   = (GlobalRdrElt -> Bool) -> [GlobalRdrElt] -> [GlobalRdrElt]
forall a. (a -> Bool) -> [a] -> [a]
filter GlobalRdrElt -> Bool
right_name (GlobalRdrEnv -> OccName -> [GlobalRdrElt]
lookupGlobalRdrEnv GlobalRdrEnv
env OccName
occ)

    -- we can mention a module P:M without the P: qualifier iff
    -- "import M" would resolve unambiguously to P:M.  (if P is the
    -- current package we can just assume it is unqualified).

mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick
mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick
mkPromTick PromotionTickContext
ptc GlobalRdrEnv
env
  | PromotionTickContext -> Bool
ptcPrintRedundantPromTicks PromotionTickContext
ptc = QueryPromotionTick
alwaysPrintPromTick
  | Bool
otherwise                      = QueryPromotionTick
print_prom_tick
  where
    print_prom_tick :: QueryPromotionTick
print_prom_tick (PromotedItemListSyntax (IsEmptyOrSingleton Bool
eos)) =
      -- Ticked: '[], '[x]
      -- Unticked: [x,y], [x,y,z], and so on
      PromotionTickContext -> Bool
ptcListTuplePuns PromotionTickContext
ptc Bool -> Bool -> Bool
&& Bool
eos
    print_prom_tick PromotedItem
PromotedItemTupleSyntax =
      PromotionTickContext -> Bool
ptcListTuplePuns PromotionTickContext
ptc
    print_prom_tick (PromotedItemDataCon OccName
occ)
      | OccName -> Bool
isPunnedDataConName OccName
occ   -- '[], '(,), ''(,,)
      = PromotionTickContext -> Bool
ptcListTuplePuns PromotionTickContext
ptc

      | Just OccName
occ' <- OccName -> Maybe OccName
promoteOccName OccName
occ
      , [] <- RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName (OccName -> RdrName
mkRdrUnqual OccName
occ') GlobalRdrEnv
env
      = -- Could not find a corresponding type name in the environment,
        -- so the data name is unambiguous. Promotion tick not needed.
        Bool
False
      | Bool
otherwise = Bool
True

isPunnedDataConName :: OccName -> Bool
isPunnedDataConName :: OccName -> Bool
isPunnedDataConName OccName
occ =
  OccName -> Bool
isDataOcc OccName
occ Bool -> Bool -> Bool
&& case FastString -> String
unpackFS (OccName -> FastString
occNameFS OccName
occ) of
    Char
'[':String
_ -> Bool
True
    Char
'(':String
_ -> Bool
True
    String
_     -> Bool
False

{- Note [pretendNameIsInScopeForPpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c.f. Note [pretendNameIsInScope] in GHC.Builtin.Names
Normally, a name is printed unqualified if it's in scope and unambiguous:
  ghci> :t not
  not :: Bool -> Bool

Out of scope names are qualified:
  ghci> import Prelude hiding (Bool)
  ghci> :t not
  not :: GHC.Types.Bool -> GHC.Types.Bool

And so are ambiguous names:
  ghci> data Bool
  ghci> :t not
  not :: Prelude.Bool -> Prelude.Bool

However, these rules alone would lead to excessive qualification:
  ghci> :k Functor
  Functor :: (GHC.Types.Type -> GHC.Types.Type) -> GHC.Types.Constraint

Even if the user has not imported Data.Kind, we would rather print:
  Functor :: (Type -> Type) -> Constraint

So we maintain a list of names for which we only require that they are
unambiguous. It reduces the amount of qualification in GHCi output and error
messages thus improving readability.

One potential problem here is that external tooling that relies on parsing GHCi
output (e.g. Emacs mode for Haskell) requires names to be properly qualified to
make sense of the output (see #11208). So extend this list with care.

Side note (int-index):
  This function is distinct from GHC.Bulitin.Names.pretendNameIsInScope (used
  when filtering out instances), and perhaps we could unify them by taking a
  union, but I have not looked into what that would entail.
-}

-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
mkQualModule UnitState
unit_state Maybe HomeUnit
mhome_unit Module
mod
     | Just HomeUnit
home_unit <- Maybe HomeUnit
mhome_unit
     , HomeUnit -> QueryQualifyModule
isHomeModule HomeUnit
home_unit Module
mod = Bool
False

     | [(Module
_, UnitInfo
pkgconfig)] <- [(Module, UnitInfo)]
lookup,
       UnitInfo -> Unit
mkUnit UnitInfo
pkgconfig Unit -> QueryQualifyPackage
forall a. Eq a => a -> a -> Bool
== Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
        -- this says: we are given a module P:M, is there just one exposed package
        -- that exposes a module M, and is it package P?
     = Bool
False

     | Bool
otherwise = Bool
True
     where lookup :: [(Module, UnitInfo)]
lookup = UnitState -> ModuleName -> [(Module, UnitInfo)]
lookupModuleInAllUnits UnitState
unit_state (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod)

-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
-- with a unit id if the package ID would be ambiguous.
mkQualPackage :: UnitState -> QueryQualifyPackage
mkQualPackage :: UnitState -> QueryQualifyPackage
mkQualPackage UnitState
pkgs Unit
uid
     | Unit
uid Unit -> QueryQualifyPackage
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit Bool -> Bool -> Bool
|| Unit
uid Unit -> QueryQualifyPackage
forall a. Eq a => a -> a -> Bool
== Unit
interactiveUnit
        -- Skip the lookup if it's main, since it won't be in the package
        -- database!
     = Bool
False
     | Just PackageId
pkgid <- Maybe PackageId
mb_pkgid
     , UnitState -> PackageId -> [UnitInfo]
searchPackageId UnitState
pkgs PackageId
pkgid [UnitInfo] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
1
        -- this says: we are given a package pkg-0.1@MMM, are there only one
        -- exposed packages whose package ID is pkg-0.1?
     = Bool
False
     | Bool
otherwise
     = Bool
True
     where mb_pkgid :: Maybe PackageId
mb_pkgid = (UnitInfo -> PackageId) -> Maybe UnitInfo -> Maybe PackageId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> PackageId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> srcpkgid
unitPackageId (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs Unit
uid)

-- | A function which only qualifies package names if necessary; but
-- qualifies all other identifiers.
pkgQual :: UnitState -> NamePprCtx
pkgQual :: UnitState -> NamePprCtx
pkgQual UnitState
pkgs = NamePprCtx
alwaysQualify { queryQualifyPackage = mkQualPackage pkgs }