{-# 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, pprWithExplicitKindsWhen,
        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.Types.Var
import GHC.Core.Multiplicity( pprArrowWithMultiplicity )
import GHC.Iface.Type

import GHC.Types.Var.Set
import GHC.Types.Var.Env

import GHC.Utils.Outputable
import GHC.Utils.Panic
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

pprTyLit :: TyLit -> SDoc
pprTyLit = pprIfaceTyLit . toIfaceTyLit

pprKind, pprParendKind :: Kind -> SDoc
pprKind       = pprType
pprParendKind = pprParendType

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.

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)
  where
    env'      = tidyFreeTyCoVars env free_tcvs
    free_tcvs = tyCoVarsOfTypeWellScoped 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 True
            ManyTy -> Left False
            _      -> 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 = tyVarSpecToBinders $ 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 kind information (with @-fprint-explicit-kinds@) when the
-- provided 'Bool' argument is 'True'.
-- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".
pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen b
  = updSDocContext $ \ctx ->
      if b then ctx { sdocPrintExplicitKinds = True }
           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