-----------------------------------------------------------------------------
--
-- Pretty-printing TyThings
--
-- (c) The GHC Team 2005
--
-----------------------------------------------------------------------------


module GHC.Types.TyThing.Ppr (
        pprTyThing,
        pprTyThingInContext,
        pprTyThingLoc,
        pprTyThingInContextLoc,
        pprTyThingHdr,
        pprFamInst
  ) where

import GHC.Prelude

import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )
import GHC.Types.Name

import GHC.Core.Type    ( ForAllTyFlag(..), mkTyVarBinders )
import GHC.Core.Coercion.Axiom ( coAxiomTyCon )
import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )
import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp )

import GHC.Iface.Decl   ( tyThingToIfaceDecl )
import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
                        , showToHeader, pprIfaceDecl )

import GHC.Utils.Outputable

import Data.Maybe ( isJust )

-- -----------------------------------------------------------------------------
-- Pretty-printing entities that we get from the GHC API

{- Note [Pretty printing via Iface syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Our general plan for pretty-printing
  - Types
  - TyCons
  - Classes
  - Pattern synonyms
  ...etc...

is to convert them to Iface syntax, and pretty-print that. For example
  - pprType converts a Type to an IfaceType, and pretty prints that.
  - pprTyThing converts the TyThing to an IfaceDecl,
    and pretty prints that.

So Iface syntax plays a dual role:
  - it's the internal version of an interface files
  - it's used for pretty-printing

Why do this?

* A significant reason is that we need to be able
  to pretty-print Iface syntax (to display Foo.hi), and it was a
  pain to duplicate masses of pretty-printing goop, esp for
  Type and IfaceType.

* When pretty-printing (a type, say), we want to tidy (with
  tidyType) to avoids having (forall a a. blah) where the two
  a's have different uniques.

  Alas, for type constructors, TyCon, tidying does not work well,
  because a TyCon includes DataCons which include Types, which mention
  TyCons. And tidying can't tidy a mutually recursive data structure
  graph, only trees.

* Interface files contains fast-strings, not uniques, so the very same
  tidying must take place when we convert to IfaceDecl. E.g.
  GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
  Class etc) to an IfaceDecl.

  Bottom line: IfaceDecls are already 'tidy', so it's straightforward
  to print them.

* An alternative I once explored was to ensure that TyCons get type
  variables with distinct print-names. That's ok for type variables
  but less easy for kind variables. Processing data type declarations
  is already so complicated that I don't think it's sensible to add
  the extra requirement that it generates only "pretty" types and
  kinds.

Consequences:

- Iface syntax (and IfaceType) must contain enough information to
  print nicely.  Hence, for example, the IfaceAppArgs type, which
  allows us to suppress invisible kind arguments in types
  (see Note [Suppressing invisible arguments] in GHC.Iface.Type)

- In a few places we have info that is used only for pretty-printing,
  and is totally ignored when turning Iface syntax back into Core
  (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon
  stores a [IfaceAxBranch] that is used only for pretty-printing.

- See Note [Free tyvars in IfaceType] in GHC.Iface.Type

See #7730, #8776 for details   -}

--------------------
-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.
pprFamInst :: FamInst -> SDoc
--  * For data instances we go via pprTyThing of the representational TyCon,
--    because there is already much cleverness associated with printing
--    data type declarations that I don't want to duplicate
--  * For type instances we print directly here; there is no TyCon
--    to give to pprTyThing
--
-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes

pprFamInst :: FamInst -> SDoc
pprFamInst (FamInst { fi_flavor :: FamInst -> FamFlavor
fi_flavor = DataFamilyInst TyCon
rep_tc })
  = TyThing -> SDoc
pprTyThingInContextLoc (TyCon -> TyThing
ATyCon TyCon
rep_tc)

pprFamInst (FamInst { fi_flavor :: FamInst -> FamFlavor
fi_flavor = FamFlavor
SynFamilyInst, fi_axiom :: FamInst -> CoAxiom Unbranched
fi_axiom = CoAxiom Unbranched
axiom
                    , fi_tvs :: FamInst -> [TyVar]
fi_tvs = [TyVar]
tvs, fi_tys :: FamInst -> [Type]
fi_tys = [Type]
lhs_tys, fi_rhs :: FamInst -> Type
fi_rhs = Type
rhs })
  = SDoc -> SDoc -> SDoc
showWithLoc (Name -> SDoc
pprDefinedAt (CoAxiom Unbranched -> Name
forall a. NamedThing a => a -> Name
getName CoAxiom Unbranched
axiom)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type instance"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ForAllTyBinder] -> SDoc
pprUserForAll (ForAllTyFlag -> [TyVar] -> [ForAllTyBinder]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders ForAllTyFlag
Specified [TyVar]
tvs)
                -- See Note [Printing foralls in type family instances]
                -- in GHC.Iface.Type
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> [Type] -> SDoc
pprTypeApp (CoAxiom Unbranched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Unbranched
axiom) [Type]
lhs_tys)
       Int
2 (SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs)

----------------------------
-- | Pretty-prints a 'TyThing' with its defining location.
pprTyThingLoc :: TyThing -> SDoc
pprTyThingLoc :: TyThing -> SDoc
pprTyThingLoc TyThing
tyThing
  = SDoc -> SDoc -> SDoc
showWithLoc (Name -> SDoc
pprDefinedAt (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
tyThing))
                (ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
showToHeader TyThing
tyThing)

-- | Pretty-prints the 'TyThing' header. For functions and data constructors
-- the function is equivalent to 'pprTyThing' but for type constructors
-- and classes it prints only the header part of the declaration.
pprTyThingHdr :: TyThing -> SDoc
pprTyThingHdr :: TyThing -> SDoc
pprTyThingHdr = ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
showToHeader

-- | Pretty-prints a 'TyThing' in context: that is, if the entity
-- is a data constructor, record selector, or class method, then
-- the entity's parent declaration is pretty-printed with irrelevant
-- parts omitted.
pprTyThingInContext :: ShowSub -> TyThing -> SDoc
pprTyThingInContext :: ShowSub -> TyThing -> SDoc
pprTyThingInContext ShowSub
show_sub TyThing
thing
  = case TyThing -> [TyThing]
parents TyThing
thing of
      -- If there are no parents print everything.
      [] -> Maybe (OccName -> Bool) -> TyThing -> SDoc
print_it Maybe (OccName -> Bool)
forall a. Maybe a
Nothing TyThing
thing
      -- If `thing` has a parent, print the parent and only its child `thing`
      TyThing
thing':[TyThing]
rest -> let subs :: [OccName]
subs = (TyThing -> OccName) -> [TyThing] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map TyThing -> OccName
forall a. NamedThing a => a -> OccName
getOccName (TyThing
thingTyThing -> [TyThing] -> [TyThing]
forall a. a -> [a] -> [a]
:[TyThing]
rest)
                         filt :: OccName -> Bool
filt = (OccName -> [OccName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OccName]
subs)
                     in Maybe (OccName -> Bool) -> TyThing -> SDoc
print_it ((OccName -> Bool) -> Maybe (OccName -> Bool)
forall a. a -> Maybe a
Just OccName -> Bool
filt) TyThing
thing'
  where
    parents :: TyThing -> [TyThing]
parents = TyThing -> [TyThing]
go
      where
        go :: TyThing -> [TyThing]
go TyThing
thing =
          case TyThing -> Maybe TyThing
tyThingParent_maybe TyThing
thing of
            Just TyThing
parent -> TyThing
parent TyThing -> [TyThing] -> [TyThing]
forall a. a -> [a] -> [a]
: TyThing -> [TyThing]
go TyThing
parent
            Maybe TyThing
Nothing     -> []

    print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc
    print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc
print_it Maybe (OccName -> Bool)
mb_filt TyThing
thing =
      ShowSub -> TyThing -> SDoc
pprTyThing (ShowSub
show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) TyThing
thing

-- | Like 'pprTyThingInContext', but adds the defining location.
pprTyThingInContextLoc :: TyThing -> SDoc
pprTyThingInContextLoc :: TyThing -> SDoc
pprTyThingInContextLoc TyThing
tyThing
  = SDoc -> SDoc -> SDoc
showWithLoc (Name -> SDoc
pprDefinedAt (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
tyThing))
                (ShowSub -> TyThing -> SDoc
pprTyThingInContext ShowSub
showToHeader TyThing
tyThing)

-- | Pretty-prints a 'TyThing'.
pprTyThing :: ShowSub -> TyThing -> SDoc
-- We pretty-print 'TyThing' via 'IfaceDecl'
-- See Note [Pretty printing via Iface syntax]
pprTyThing :: ShowSub -> TyThing -> SDoc
pprTyThing ShowSub
ss TyThing
ty_thing
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocLinearTypes ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Bool
show_linear_types ->
      ShowSub -> IfaceDecl -> SDoc
pprIfaceDecl ShowSub
ss' (Bool -> TyThing -> IfaceDecl
tyThingToIfaceDecl Bool
show_linear_types TyThing
ty_thing)
  where
    ss' :: ShowSub
ss' = case ShowSub -> ShowHowMuch
ss_how_much ShowSub
ss of
      ShowHeader (AltPpr Maybe (OccName -> SDoc)
Nothing)    -> ShowSub
ss { ss_how_much = ShowHeader ppr' }
      ShowSome Maybe (OccName -> Bool)
filt (AltPpr Maybe (OccName -> SDoc)
Nothing) -> ShowSub
ss { ss_how_much = ShowSome filt ppr' }
      ShowHowMuch
_                   -> ShowSub
ss

    ppr' :: AltPpr
ppr' = Maybe (OccName -> SDoc) -> AltPpr
AltPpr (Maybe (OccName -> SDoc) -> AltPpr)
-> Maybe (OccName -> SDoc) -> AltPpr
forall a b. (a -> b) -> a -> b
$ Name -> Maybe (OccName -> SDoc)
ppr_bndr (Name -> Maybe (OccName -> SDoc))
-> Name -> Maybe (OccName -> SDoc)
forall a b. (a -> b) -> a -> b
$ TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
ty_thing

    ppr_bndr :: Name -> Maybe (OccName -> SDoc)
    ppr_bndr :: Name -> Maybe (OccName -> SDoc)
ppr_bndr Name
name
      | Name -> Bool
isBuiltInSyntax Name
name Bool -> Bool -> Bool
|| Maybe FastString -> Bool
forall a. Maybe a -> Bool
isJust (Name -> Maybe FastString
namePun_maybe Name
name)
         = Maybe (OccName -> SDoc)
forall a. Maybe a
Nothing
      | Bool
otherwise
         = case Name -> Maybe Module
nameModule_maybe Name
name of
             Just Module
mod -> (OccName -> SDoc) -> Maybe (OccName -> SDoc)
forall a. a -> Maybe a
Just ((OccName -> SDoc) -> Maybe (OccName -> SDoc))
-> (OccName -> SDoc) -> Maybe (OccName -> SDoc)
forall a b. (a -> b) -> a -> b
$ \OccName
occ -> (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \PprStyle
sty ->
               PprStyle -> Module -> OccName -> SDoc
pprModulePrefix PprStyle
sty Module
mod OccName
occ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ
             Maybe Module
Nothing  -> Bool
-> String
-> SDoc
-> Maybe (OccName -> SDoc)
-> Maybe (OccName -> SDoc)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"pprTyThing" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) Maybe (OccName -> SDoc)
forall a. Maybe a
Nothing
             -- Nothing is unexpected here; TyThings have External names

showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc :: SDoc -> SDoc -> SDoc
showWithLoc SDoc
loc SDoc
doc
    = SDoc -> Int -> SDoc -> SDoc
hang SDoc
doc Int
2 (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'\t' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
comment SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
loc)
                -- The tab tries to make them line up a bit
  where
    comment :: SDoc
comment = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"--"