content: {-# LANGUAGE PatternSynonyms #-}
  
  -- | Pretty-printing types and coercions.
  module GHC.Core.TyCo.Ppr
    (
          -- * Precedence
          PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
  
          -- * Pretty-printing types
          pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX,
          pprTypeApp, pprTCvBndr, pprTCvBndrs,
          pprSigmaType,
          pprTheta, pprParendTheta, pprForAll, pprUserForAll,
          pprTyVar, pprTyVars,
          pprThetaArrowTy, pprClassPred,
          pprKind, pprParendKind, pprTyLit,
          pprDataCons, pprWithInvisibleBitsWhen,
          pprWithTYPE, pprSourceTyCon,
  
  
          -- * Pretty-printing coercions
          pprCo, pprParendCo,
  
          debugPprType,
    ) where
  
  import GHC.Prelude
  
  import {-# SOURCE #-} GHC.CoreToIface
     ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs
     , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )
  
  import {-# SOURCE #-} GHC.Core.DataCon
     ( dataConFullSig , dataConUserTyVarBinders, DataCon )
  
  import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern OneTy, pattern ManyTy,
                         splitForAllReqTyBinders, splitForAllInvisTyBinders )
  
  import GHC.Core.TyCon
  import GHC.Core.TyCo.Rep
  import GHC.Core.TyCo.Tidy
  import GHC.Core.TyCo.FVs
  import GHC.Core.Class
  import GHC.Core.Predicate( scopedSort )
  import GHC.Core.Multiplicity( pprArrowWithMultiplicity )
  
  import GHC.Types.Var
  
  import GHC.Iface.Type
  
  import GHC.Types.Var.Set
  import GHC.Types.Var.Env
  
  import GHC.Utils.Outputable
  import GHC.Utils.Panic
  
  import GHC.Base ( Multiplicity(..) )
  import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec
                         , funPrec, appPrec, maybeParen )
  
  {-
  %************************************************************************
  %*                                                                      *
                     Pretty-printing types
  
         Defined very early because of debug printing in assertions
  %*                                                                      *
  %************************************************************************
  
  @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
  defined to use this.  @pprParendType@ is the same, except it puts
  parens around the type, except for the atomic cases.  @pprParendType@
  works just by setting the initial context precedence very high.
  
  Note that any function which pretty-prints a @Type@ first converts the @Type@
  to an @IfaceType@. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr.
  
  See Note [Precedence in types] in GHC.Types.Basic.
  -}
  
  pprType, pprParendType, pprTidiedType :: Type -> SDoc
  pprType       = pprPrecType topPrec
  pprParendType = pprPrecType appPrec
  
  -- already pre-tidied
  pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet
  
  pprPrecType :: PprPrec -> Type -> SDoc
  pprPrecType = pprPrecTypeX emptyTidyEnv
  
  pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc
  pprPrecTypeX env prec ty
    = getPprStyle $ \sty ->
      getPprDebug $ \debug ->
      if debug                    -- Use debugPprType when in
      then debug_ppr_ty prec ty   -- when in debug-style
      else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty)
      -- NB: debug-style is used for -dppr-debug
      --     dump-style  is used for -ddump-tc-trace etc
  
  tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType
  tidyToIfaceTypeStyX env ty sty
    | userStyle sty = tidyToIfaceTypeX env ty
    | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty
       -- in latter case, don't tidy, as we'll be printing uniques.
  
  
  pprTyLit :: TyLit -> SDoc
  pprTyLit = pprIfaceTyLit . toIfaceTyLit
  
  pprKind, pprParendKind :: Kind -> SDoc
  pprKind       = pprType
  pprParendKind = pprParendType
  
  tidyToIfaceType :: Type -> IfaceType
  tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv
  
  tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType
  -- It's vital to tidy before converting to an IfaceType
  -- or nested binders will become indistinguishable!
  --
  -- Also for the free type variables, tell toIfaceTypeX to
  -- leave them as IfaceFreeTyVar.  This is super-important
  -- for debug printing.
  tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty)
    -- NB: if the type has /already/ been tidied (for example by the typechecker)
    --     the tidy step here is a no-op.  See Note [Tidying is idempotent]
    --     in GHC.Core.TyCo.Tidy
    where
      env'      = tidyFreeTyCoVars env free_tcvs
      free_tcvs = tyCoVarsOfTypeList ty
  
  ------------
  pprCo, pprParendCo :: Coercion -> SDoc
  pprCo       co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)
  pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)
  
  tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion
  tidyToIfaceCoSty co sty
    | userStyle sty = tidyToIfaceCo co
    | otherwise     = toIfaceCoercionX (tyCoVarsOfCo co) co
       -- in latter case, don't tidy, as we'll be printing uniques.
  
  tidyToIfaceCo :: Coercion -> IfaceCoercion
  -- It's vital to tidy before converting to an IfaceType
  -- or nested binders will become indistinguishable!
  --
  -- Also for the free type variables, tell toIfaceCoercionX to
  -- leave them as IfaceFreeCoVar.  This is super-important
  -- for debug printing.
  tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)
    where
      env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs
      free_tcvs = scopedSort $ tyCoVarsOfCoList co
  ------------
  pprClassPred :: Class -> [Type] -> SDoc
  pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
  
  ------------
  pprTheta :: ThetaType -> SDoc
  pprTheta = pprIfaceContext topPrec . map tidyToIfaceType
  
  pprParendTheta :: ThetaType -> SDoc
  pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType
  
  pprThetaArrowTy :: ThetaType -> SDoc
  pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType
  
  ------------------
  pprSigmaType :: Type -> SDoc
  pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType
  
  pprForAll :: [ForAllTyBinder] -> SDoc
  pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs)
  
  -- | Print a user-level forall; see @Note [When to print foralls]@ in
  -- "GHC.Iface.Type".
  pprUserForAll :: [ForAllTyBinder] -> SDoc
  pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs
  
  pprTCvBndrs :: [ForAllTyBinder] -> SDoc
  pprTCvBndrs tvs = sep (map pprTCvBndr tvs)
  
  pprTCvBndr :: ForAllTyBinder -> SDoc
  pprTCvBndr = pprTyVar . binderVar
  
  pprTyVars :: [TyVar] -> SDoc
  pprTyVars tvs = sep (map pprTyVar tvs)
  
  pprTyVar :: TyVar -> SDoc
  -- Print a type variable binder with its kind (but not if *)
  -- Here we do not go via IfaceType, because the duplication with
  -- pprIfaceTvBndr is minimal, and the loss of uniques etc in
  -- debug printing is disastrous
  pprTyVar tv
    | pickyIsLiftedTypeKind kind = ppr tv  -- See Note [Suppressing * kinds]
    | otherwise                  = parens (ppr tv <+> dcolon <+> ppr kind)
    where
      kind = tyVarKind tv
  
  {- Note [Suppressing * kinds]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Generally we want to print
        forall a. a->a
  not   forall (a::*). a->a
  or    forall (a::Type). a->a
  That is, for brevity we suppress a kind ascription of '*' (or Type).
  
  But what if the kind is (Const Type x)?
     type Const p q = p
  
  Then (Const Type x) is just a long way of saying Type.  But it may be
  jolly confusing to suppress the 'x'.  Suppose we have (polykinds/T18451a)
     foo :: forall a b (c :: Const Type b). Proxy '[a, c]
  
  Then this error message
      • These kind and type variables: a b (c :: Const Type b)
        are out of dependency order. Perhaps try this ordering:
          (b :: k) (a :: Const (*) b) (c :: Const (*) b)
  would be much less helpful if we suppressed the kind ascription on 'a'.
  
  Hence the use of pickyIsLiftedTypeKind.
  -}
  
  -----------------
  debugPprType :: Type -> SDoc
  -- ^ debugPprType is a simple pretty printer that prints a type
  -- without going through IfaceType.  It does not format as prettily
  -- as the normal route, but it's much more direct, and that can
  -- be useful for debugging.  E.g. with -dppr-debug it prints the
  -- kind on type-variable /occurrences/ which the normal route
  -- fundamentally cannot do.
  debugPprType ty = debug_ppr_ty topPrec ty
  
  debug_ppr_ty :: PprPrec -> Type -> SDoc
  debug_ppr_ty _ (LitTy l)
    = ppr l
  
  debug_ppr_ty _ (TyVarTy tv)
    = ppr tv  -- With -dppr-debug we get (tv :: kind)
  
  debug_ppr_ty prec (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })
    = maybeParen prec funPrec $
      sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res]
    where
      arr = pprArrowWithMultiplicity af $
            case mult of
              OneTy  -> Left One
              ManyTy -> Left Many
              _      -> Right (debug_ppr_ty appPrec mult)
  
  debug_ppr_ty prec (TyConApp tc tys)
    | null tys  = ppr tc
    | otherwise = maybeParen prec appPrec $
                  hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))
  
  debug_ppr_ty _ (AppTy t1 t2)
    = hang (debug_ppr_ty appPrec t1)  -- Print parens so we see ((a b) c)
         2 (debug_ppr_ty appPrec t2)  -- so that we can distinguish
                                      -- TyConApp from AppTy
  
  debug_ppr_ty prec (CastTy ty co)
    = maybeParen prec topPrec $
      hang (debug_ppr_ty topPrec ty)
         2 (text "|>" <+> ppr co)
  
  debug_ppr_ty _ (CoercionTy co)
    = parens (text "CO" <+> ppr co)
  
  -- Invisible forall:  forall {k} (a :: k). t
  debug_ppr_ty prec t
    | (bndrs, body) <- splitForAllInvisTyBinders t
    , not (null bndrs)
    = maybeParen prec funPrec $
      sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot,
            ppr body ]
    where
      -- (ppr tv) will print the binder kind-annotated
      -- when in debug-style
      ppr_bndr (Bndr tv InferredSpec)  = braces (ppr tv)
      ppr_bndr (Bndr tv SpecifiedSpec) = ppr tv
  
  -- Visible forall:  forall x y -> t
  debug_ppr_ty prec t
    | (bndrs, body) <- splitForAllReqTyBinders t
    , not (null bndrs)
    = maybeParen prec funPrec $
      sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow,
            ppr body ]
    where
      -- (ppr tv) will print the binder kind-annotated
      -- when in debug-style
      ppr_bndr (Bndr tv ()) = ppr tv
  
  -- Impossible case: neither visible nor invisible forall.
  debug_ppr_ty _ ForAllTy{}
    = panic "debug_ppr_ty: neither splitForAllInvisTyBinders nor splitForAllReqTyBinders returned any binders"
  
  {-
  Note [Infix type variables]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  With TypeOperators you can say
  
     f :: (a ~> b) -> b
  
  and the (~>) is considered a type variable.  However, the type
  pretty-printer in this module will just see (a ~> b) as
  
     App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")
  
  So it'll print the type in prefix form.  To avoid confusion we must
  remember to parenthesise the operator, thus
  
     (~>) a b -> b
  
  See #2766.
  -}
  
  pprDataCons :: TyCon -> SDoc
  pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons
    where
      sepWithVBars [] = empty
      sepWithVBars docs = sep (punctuate (space <> vbar) docs)
  
  pprDataConWithArgs :: DataCon -> SDoc
  pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
    where
      (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
      user_bndrs = dataConUserTyVarBinders dc
      forAllDoc  = pprUserForAll user_bndrs
      thetaDoc   = pprThetaArrowTy theta
      argsDoc    = hsep (fmap pprParendType (map scaledThing arg_tys))
  
  
  pprTypeApp :: TyCon -> [Type] -> SDoc
  pprTypeApp tc tys
    = pprIfaceTypeApp topPrec (toIfaceTyCon tc)
                              (toIfaceTcArgs tc tys)
      -- TODO: toIfaceTcArgs seems rather wasteful here
  
  ------------------
  -- | Display all foralls, runtime-reps, and kind information
  -- when provided 'Bool' argument is 'True'.  See GHC.Tc.Errors.Ppr
  -- Note [Showing invisible bits of types in error messages]
  pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc
  pprWithInvisibleBitsWhen b
    = updSDocContext $ \ctx ->
        if b then ctx { sdocPrintExplicitKinds       = True
                      , sdocPrintExplicitRuntimeReps = True }
    -- NB: not turning on LinearTypes by default here.
    -- See pprWithInvisibleBits, which can enable LinearTypes for pretty-printing.
             else ctx
  
  -- | This variant preserves any use of TYPE in a type, effectively
  -- locally setting -fprint-explicit-runtime-reps.
  pprWithTYPE :: Type -> SDoc
  pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $
                   ppr ty
  
  -- | Pretty prints a 'TyCon', using the family instance in case of a
  -- representation tycon.  For example:
  --
  -- > data T [a] = ...
  --
  -- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
  pprSourceTyCon :: TyCon -> SDoc
  pprSourceTyCon tycon
    | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
    = ppr $ fam_tc `TyConApp` tys        -- can't be FunTyCon
    | otherwise
    = ppr tycon
  