Pretty.hs

{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016     , Myrtle Software Ltd,
                     2021-2022, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  PrettyPrec printing class and instances for CoreHW
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Clash.Core.Pretty
  ( PrettyPrec (..)
  , PrettyOptions (..)
  , ClashDoc
  , ClashAnnotation (..)
  , SyntaxElement (..)
  , ppr, ppr'
  , showPpr, showPpr'
  , tracePprId
  , tracePpr
  , fromPpr
  )
where

import Data.Char                        (isSymbol, isUpper, ord)
import Data.Default                     (Default(..))
import Data.Text                        (Text)
import Control.Monad.Identity
import Data.Binary.IEEE754              (wordToDouble, wordToFloat)
import Data.List.Extra                  ((<:>))
import qualified Data.Text              as T
import Data.Maybe                       (fromMaybe)
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
import Prettyprinter.Internal
#else
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal
#endif
import GHC.Show                         (showMultiLineString)
import GHC.Stack                        (HasCallStack)
#if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Utils.Outputable   as GHC
#else
import qualified Outputable             as GHC
#endif
import System.Environment               (lookupEnv)
import System.IO.Unsafe                 (unsafePerformIO)
import Text.Read                        (readMaybe)

import Clash.Core.DataCon               (DataCon (..))
import Clash.Core.Literal               (Literal (..))
import Clash.Core.Name                  (Name (..))
import Clash.Core.Term
  (Pat (..), Term (..), TickInfo (..), NameMod (..), CoreContext (..), primArg, PrimInfo(primName),Bind(..))
import Clash.Core.TyCon                 (TyCon (..), TyConName, isTupleTyConLike, AlgTyConRhs(..))
import Clash.Core.Type                  (ConstTy (..), Kind, LitTy (..),
                                         Type (..), TypeView (..), tyView,mkTyConApp)
import Clash.Core.Var                   (Id, TyVar, Var (..), IdScope(..))
import Clash.Debug                      (trace)
import Clash.Util
import qualified Clash.Util.Interpolate as I
import Clash.Pretty

unsafeLookupEnvBool :: HasCallStack =>  String -> Bool -> Bool
unsafeLookupEnvBool key dflt =
  case unsafePerformIO (lookupEnv key) of
    Nothing -> dflt
    Just a -> flip fromMaybe (readMaybe a) $ error [I.i|
      'unsafeLookupEnvBool' tried to lookup #{key} in the environment. It found
      it, but couldn't interpret it to as a Bool. Expected one of: True, False.
      But found:

        #{a}
    |]

-- | Options for the pretty-printer, controlling which elements to hide.
data PrettyOptions = PrettyOptions
  { displayUniques    :: Bool
  -- ^ whether to display unique identifiers
  , displayTypes      :: Bool
  -- ^ whether to display type information
  , displayQualifiers :: Bool
  -- ^ whether to display module qualifiers
  , displayTicks      :: Bool
  -- ^ whether to display ticks
  }

instance Default PrettyOptions where
  def = PrettyOptions
    { displayUniques    = unsafeLookupEnvBool "CLASH_PPR_UNIQUES" True
    , displayTypes      = unsafeLookupEnvBool "CLASH_PPR_TYPES" True
    , displayQualifiers = unsafeLookupEnvBool "CLASH_PPR_QUALIFIERS" True
    , displayTicks      = unsafeLookupEnvBool "CLASH_PPR_TICKS" True
    }

-- | Annotations carried on pretty-printed code.
data ClashAnnotation
  = AnnContext CoreContext
  -- ^ marking navigation to a different context
  | AnnSyntax  SyntaxElement
  -- ^ marking a specific sort of syntax
  deriving Eq

-- | Specific places in the program syntax.
data SyntaxElement = Keyword | LitS | Type | Unique | Qualifier | Ticky
  deriving (Eq, Show)

-- | Clash's specialized @Doc@ type holds metadata of type @ClashAnnotation@.
type ClashDoc = Doc ClashAnnotation

-- | PrettyPrec printing Show-like typeclass
class PrettyPrec p where

  -- default pretty-printing without hiding
  pprPrec :: Monad m => Rational -> p -> m ClashDoc

  -- pretty-printing with hiding options
  -- NB: we utilise the syntax annotations to hide the requested parts of syntax
  pprPrec' :: Monad m => PrettyOptions -> Rational -> p -> m ClashDoc
  pprPrec' opts p = fmap hide . pprPrec p
    where
      hide = \case
        FlatAlt d d'         -> FlatAlt (hide d) (hide d')
        Cat d d'             -> Cat (hide d) (hide d')
        Nest i d             -> Nest i (hide d)
        Union d d'           -> Union (hide d) (hide d')
        Column f             -> Column (hide . f)
        WithPageWidth f      -> WithPageWidth (hide . f)
        Nesting f            -> Nesting (hide . f)
        Annotated ann d'     ->
          if not (displayTypes opts)      && ann == AnnSyntax Type
          || not (displayUniques opts)    && ann == AnnSyntax Unique
          || not (displayQualifiers opts) && ann == AnnSyntax Qualifier
          || not (displayTicks opts)      && ann == AnnSyntax Ticky
            then Empty
            else Annotated ann (hide d')
        d -> d

pprM :: (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM = pprPrec 0

pprM' :: (Monad m, PrettyPrec p) => PrettyOptions -> p -> m ClashDoc
pprM' opts = pprPrec' opts 0

ppr :: PrettyPrec p => p -> ClashDoc
ppr = runIdentity . pprM

ppr' :: PrettyPrec p => PrettyOptions -> p -> ClashDoc
ppr' opts = runIdentity . pprM' opts

fromPpr :: PrettyPrec a => a -> Doc ()
fromPpr = removeAnnotations . ppr

noPrec, opPrec, appPrec :: Num a => a
noPrec = 0
opPrec = 1
appPrec = 2

-- | Print a PrettyPrec thing to a String
showPpr :: PrettyPrec p => p -> String
showPpr = showPpr' def

showPpr' :: PrettyPrec p => PrettyOptions -> p -> String
showPpr' opts = showDoc . ppr' opts

tracePprId :: PrettyPrec p => p -> p
tracePprId p = trace (showPpr p) p

tracePpr :: PrettyPrec p => p -> a -> a
tracePpr p a = trace (showPpr p) a

parensIf :: Bool -> ClashDoc -> ClashDoc
parensIf False = id
parensIf True  = parens

tyParens :: ClashDoc -> ClashDoc
tyParens = enclose (annotate (AnnSyntax Type) lparen)
                   (annotate (AnnSyntax Type) rparen)

tyParensIf :: Bool -> ClashDoc -> ClashDoc
tyParensIf False = id
tyParensIf True  = tyParens

vsepHard :: [ClashDoc] -> ClashDoc
vsepHard = concatWith (\x y -> x <> hardline <> y)

viewName :: Name a -> (Text, Text, Text)
viewName n = (qual, occ, T.pack $ show $ nameUniq n)
  where (qual, occ) = T.breakOnEnd "." $ nameOcc n

instance PrettyPrec (Name a) where
  pprPrec p (viewName -> (qual, occ, uniq)) = do
    qual' <- annotate (AnnSyntax Qualifier) <$> pprPrec p qual
    occ'  <- pprPrec p occ
    uniq' <- annotate (AnnSyntax Unique) . brackets <$> (pprPrec p uniq)
    return $ qual' <> occ' <> uniq'

instance ClashPretty (Name a) where
  clashPretty = fromPpr

instance PrettyPrec a => PrettyPrec [a] where
  pprPrec prec = fmap vcat . mapM (pprPrec prec)

instance PrettyPrec (Id, Term) where
  pprPrec _ = pprTopLevelBndr

pprTopLevelBndr :: Monad m => (Id,Term) -> m ClashDoc
pprTopLevelBndr (bndr,expr) = do
  bndr'    <- pprM bndr
  bndrName <- pprM (varName bndr)
  expr'    <- pprM expr
  return $ bndr' <> line <> hang 2 (sep [(bndrName <+> equals), expr']) <> line

dcolon, rarrow, lam, tylam, at, cast, coerce, let_, letrec, in_, case_, of_, forall_,
  data_,newtype_,type_,family_,instance_
  :: ClashDoc
dcolon = annotate (AnnSyntax Keyword) "::"
rarrow = annotate (AnnSyntax Keyword) "->"
lam = annotate (AnnSyntax Keyword)  "λ"
tylam = annotate (AnnSyntax Keyword) "Λ"
at = annotate (AnnSyntax Keyword)  "@"
cast = annotate (AnnSyntax Keyword) "▷"
coerce = annotate (AnnSyntax Keyword) "~"
let_ = annotate (AnnSyntax Keyword) "let"
letrec = annotate (AnnSyntax Keyword) "letrec"
in_ = annotate (AnnSyntax Keyword) "in"
case_ = annotate (AnnSyntax Keyword) "case"
of_ = annotate (AnnSyntax Keyword) "of"
forall_ = annotate (AnnSyntax Keyword) "forall"
data_ = annotate (AnnSyntax Keyword) "data"
newtype_ = annotate (AnnSyntax Keyword) "newtype"
type_ = annotate (AnnSyntax Keyword) "type"
family_ = annotate (AnnSyntax Keyword) "family"
instance_ = annotate (AnnSyntax Keyword) "instance"

instance PrettyPrec Text where
  pprPrec _ = pure . pretty

instance PrettyPrec Type where
  pprPrec _ t = pprType t

instance ClashPretty Type where
  clashPretty = fromPpr

instance PrettyPrec TyCon where
  pprPrec prec t = case t of
    AlgTyCon _ nm kn _ (DataTyCon dcs) _ -> do
      name <- pprPrec prec nm
      kind <- pprKind kn
      let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)

      cons <- traverse pprDataCon dcs
      pure (vsep (data_ <+> decl : cons))
     where
      pprDataCon dc = do
        name <- pprPrec prec dc
        ty <- pprType (dcType dc)

        pure (name <> annotate (AnnSyntax Type) (space <> dcolon <+> ty))

    AlgTyCon _ nm kn _ (NewTyCon dc _) _ -> do
      name <- pprPrec prec nm
      kind <- pprKind kn
      let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)

      conName <- pprPrec prec (dcName dc)
      conType <- pprType (dcType dc)

      pure (vsep [newtype_ <+> decl, conName <> annotate (AnnSyntax Type) (space <> dcolon <+> conType)])

    PromotedDataCon _ _ _ _ dc ->
      fmap ("promoted" <+>) (pprPrec prec dc)

    FunTyCon _ nm kn _ ss -> do
      name <- pprPrec prec nm
      kind <- pprKind kn
      let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)

      substs <- traverse pprSubst ss
      pure (vsep (type_ <+> family_ <+> decl : substs))
     where
      pprSubst (xs, y) = do
        lhs <- pprType (mkTyConApp (tyConName t) xs)
        rhs <- pprType y

        pure (type_ <+> instance_ <+> lhs <+> "=" <+> rhs)

    PrimTyCon _ nm kn _ -> do
      name <- pprPrec prec nm
      kind <- pprKind kn

      pure (name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind))

instance Pretty LitTy where
  pretty (NumTy i) = pretty i
  pretty (SymTy s) = dquotes $ pretty s
  pretty (CharTy c) = squotes $ pretty c

instance PrettyPrec LitTy where
  pprPrec _ = return . annotate (AnnSyntax LitS) . pretty

instance PrettyPrec Term where
  pprPrec prec e = case e of
    Var x           -> do
      v <- pprPrec prec (varName x)
      s <- pprPrecIdScope x
      pure (v <> annotate (AnnSyntax Unique) (brackets s))
    Data dc         -> pprPrec prec dc
    Literal l       -> pprPrec prec l
    Prim p          -> pprPrecPrim prec (primName p)
    Lam  v e1       -> annotate (AnnContext $ LamBody v) <$>
                         pprPrecLam prec [v] e1
    TyLam tv e1     -> annotate (AnnContext $ TyLamBody tv) <$>
                         pprPrecTyLam prec [tv] e1
    App fun arg     -> pprPrecApp prec fun arg
    TyApp e' ty     -> annotate (AnnContext TyAppC) <$>
                         pprPrecTyApp prec e' ty
    Let (NonRec i x) e1 -> pprPrecLetrec prec False [(i,x)] e1
    Let (Rec xes) e1   -> pprPrecLetrec prec True xes e1
    Case e' _ alts  -> pprPrecCase prec e' alts
    Cast e' ty1 ty2 -> pprPrecCast prec e' ty1 ty2
    Tick t e'       -> do
      tDoc <- pprPrec prec t
      eDoc <- pprPrec prec e'
      return (annotate (AnnSyntax Ticky) (tDoc <> line') <> eDoc)

instance PrettyPrec TickInfo where
  pprPrec prec (SrcSpan sp)   = pprPrec prec sp
  pprPrec prec (NameMod PrefixName t) = ("<prefixName>" <>) <$> pprPrec prec t
  pprPrec prec (NameMod SuffixName t) = ("<suffixName>" <>) <$> pprPrec prec t
  pprPrec prec (NameMod SuffixNameP t) = ("<suffixNameP>" <>) <$> pprPrec prec t
  pprPrec prec (NameMod SetName t)    = ("<setName>" <>) <$> pprPrec prec t
  pprPrec _    DeDup                  = pure "<deDup>"
  pprPrec _    NoDeDup                = pure "<noDeDup>"
  pprPrec prec (Attributes _ attrs)   = ("<attributes>" <>) <$> pprPrec prec attrs

instance PrettyPrec SrcSpan where
  pprPrec _ sp = return ("<src>"<>pretty (GHC.showSDocUnsafe (GHC.ppr sp)))

instance ClashPretty Term where
  clashPretty = fromPpr

data BindingSite = LambdaBind | CaseBind | LetBind

instance PrettyPrec (Var a) where
  pprPrec _ v@(TyVar {}) = pprM $ varName v
  pprPrec _ v@(Id {})    = do
    v'  <- pprM (varName v)
    ty' <- pprM (varType v)
    return $ v' <> (annotate (AnnSyntax Type) $ align (space <> dcolon <+> ty'))

instance ClashPretty (Var a) where
  clashPretty = fromPpr

instance PrettyPrec DataCon where
  pprPrec _ = pprM . dcName

instance PrettyPrec Literal where
  pprPrec _ l = return $ annotate (AnnSyntax LitS) $ case l of
    IntegerLiteral i   -> parensIf (i < 0) (pretty i)
    IntLiteral i       -> parensIf (i < 0) (pretty i <> "#")
    Int64Literal i     -> parensIf (i < 0) (pretty i <> "#64")
    WordLiteral w      -> pretty w <> "##"
    Word64Literal w    -> pretty w <> "##64"
#if MIN_VERSION_ghc(8,8,0)
    Int8Literal i      -> parensIf (i < 0) (pretty i <> "#8")
    Int16Literal i     -> parensIf (i < 0) (pretty i <> "#16")
    Int32Literal i     -> parensIf (i < 0) (pretty i <> "#32")
    Word8Literal w     -> pretty w <> "##8"
    Word16Literal w    -> pretty w <> "##16"
    Word32Literal w    -> pretty w <> "##32"
#endif
    FloatLiteral w     -> pretty (wordToFloat w) <> "#"
    DoubleLiteral w    -> pretty (wordToDouble w) <> "##"
    CharLiteral c      -> pretty c <> "#"
    StringLiteral s    -> vcat $ map pretty $ showMultiLineString s
    NaturalLiteral n   -> pretty n
    ByteArrayLiteral s -> pretty $ show s

instance PrettyPrec Pat where
  pprPrec prec pat = case pat of
    DataPat dc txs xs -> do
      dc'  <- pprM dc
      txs' <- mapM (pprBndr LetBind) txs
      xs'  <- mapM (pprBndr CaseBind) xs
      return $ parensIf (prec >= appPrec) $
        sep [ hsep (dc':txs')
            , nest 2 (sep xs') ]
    LitPat l   -> pprM l
    DefaultPat -> return "_"

pprPrecIdScope :: Monad m => Var a -> m ClashDoc
pprPrecIdScope (TyVar {}) = pure "TyVar"
pprPrecIdScope (Id _ _ _ GlobalId) = pure "GlobalId"
pprPrecIdScope (Id _ _ _ LocalId) = pure "LocalId"

pprPrecPrim :: Monad m => Rational -> Text -> m ClashDoc
pprPrecPrim prec nm =
  (<>) <$> (annotate (AnnSyntax Qualifier) <$> pprPrec prec qual)
       <*> pprPrec prec occ
  where (qual, occ) = T.breakOnEnd "." nm

pprPrecLam :: Monad m => Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam prec xs e = do
  xs' <- mapM (pprBndr LambdaBind) xs
  e'  <- pprPrec noPrec e
  return $ parensIf (prec > noPrec) $
    lam <> hsep xs' <+> rarrow <> line <> e'

pprPrecTyLam :: Monad m => Rational -> [TyVar] -> Term -> m ClashDoc
pprPrecTyLam prec tvs e = do
  tvs' <- mapM pprM tvs
  e'   <- pprPrec noPrec e
  return $ tyParensIf (prec > noPrec) $
    annotate (AnnSyntax Type) (tylam <> hsep tvs' <+> rarrow <> line) <> e'

pprPrecApp :: Monad m => Rational -> Term -> Term -> m ClashDoc
pprPrecApp prec e1 e2 = do
  e1' <- annotate (AnnContext AppFun) <$> pprPrec opPrec e1
  e2' <- annotate (AnnContext $ AppArg $ primArg e2) <$> pprPrec appPrec e2
  return $ parensIf (prec >= appPrec) $
    hang 2 (sep [e1',e2'])

pprPrecTyApp :: Monad m => Rational -> Term -> Type -> m ClashDoc
pprPrecTyApp prec e ty = do
  e'  <- pprPrec opPrec e
  ty' <- pprParendType ty
  return $ tyParensIf (prec >= appPrec) $
    hang 2 $ group $
      e' <> annotate (AnnSyntax Type) (line <> at <> ty')

pprPrecCast :: Monad m => Rational -> Term -> Type -> Type -> m ClashDoc
pprPrecCast prec e ty1 ty2 = do
  e'   <- annotate (AnnContext CastBody) <$> pprPrec appPrec e
  ty1' <- pprType ty1
  ty2' <- pprType ty2
  return $ tyParensIf (prec >= appPrec) $
    e' <> annotate (AnnSyntax Type)
                   (softline <> nest 2 (vsep [cast, ty1', coerce, ty2']))

-- TODO Since Clash now keeps non-recursive let expressions separately, the
-- result of normalization will contain more nested let expressions as the old
-- Letrec-based definitions are replaced by Let. As this happens, it may be a
-- good idea to change pprPrecLetrec to encourage more compact forms such as
-- printing the entire binding on one line if possible.

pprPrecLetrec :: Monad m => Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec prec isRec xes body = do
  let bndrs = fst <$> xes
  body' <- annotate (AnnContext $ LetBody xes) <$> pprPrec noPrec body
  xes'  <- mapM (\(x,e) -> do
                  x' <- pprBndr LetBind x
                  e' <- pprPrec noPrec e
                  return $ annotate (AnnContext $ LetBinding x bndrs) $
                    vsepHard [x', equals <+> e']
                ) xes
  let xes'' = case xes' of { [] -> ["EmptyLetrec"]; _  -> xes' }
  let kw = if isRec then letrec else let_
  return $ parensIf (prec > noPrec) $
    vsepHard [hang 2 (vsepHard $ kw : xes''), in_ <+> body']

pprPrecCase :: Monad m => Rational -> Term -> [(Pat,Term)] -> m ClashDoc
pprPrecCase prec e alts = do
  e'    <- annotate (AnnContext CaseScrut) <$> pprPrec prec e
  alts' <- mapM (pprPrecAlt noPrec) alts
  return $ parensIf (prec > noPrec) $
    hang 2 $ vsepHard $ (case_ <+> e' <+> of_) : alts'

pprPrecAlt :: Monad m => Rational -> (Pat,Term) -> m ClashDoc
pprPrecAlt _ (altPat, altE) = do
  altPat' <- pprPrec noPrec altPat
  altE'   <- pprPrec noPrec altE
  return $ annotate (AnnContext $ CaseAlt altPat) $
    hang 2 $ vsepHard [(altPat' <+> rarrow), altE']

pprBndr :: (Monad m, PrettyPrec a) => BindingSite -> a -> m ClashDoc
pprBndr LetBind = pprM
pprBndr _       = fmap tyParens . pprM

data TypePrec = TopPrec | FunPrec | TyConPrec deriving (Eq,Ord)

maybeParen :: TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen ctxt_prec inner_prec = parensIf (ctxt_prec >= inner_prec)

pprType :: Monad m => Type -> m ClashDoc
pprType = ppr_type TopPrec

pprParendType :: Monad m => Type -> m ClashDoc
pprParendType = ppr_type TyConPrec

ppr_type :: Monad m => TypePrec -> Type -> m ClashDoc
ppr_type _ (VarTy tv)                   = pprM tv
ppr_type _ (LitTy tyLit)                = pprM tyLit
ppr_type p ty@(ForAllTy {})             = pprForAllType p ty
ppr_type p (ConstTy (TyCon tc))         = pprTcApp p ppr_type tc []
ppr_type p (AnnType _ann typ)           = ppr_type p typ
ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args
ppr_type p (tyView -> FunTy ty1 ty2)
  = pprArrowChain <$> ppr_type FunPrec ty1 <:> pprFunTail ty2
  where
    pprFunTail (tyView -> FunTy ty1' ty2')
      = ppr_type FunPrec ty1' <:> pprFunTail ty2'
    pprFunTail otherTy
      = ppr_type TopPrec otherTy <:> pure []

    pprArrowChain []
      = emptyDoc
    pprArrowChain (arg:args)
      = maybeParen p FunPrec $ sep [arg, sep (map (rarrow <+>) args)]

ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1
                                                               <*> ppr_type TyConPrec ty2)
ppr_type _ (ConstTy Arrow) = return (parens rarrow)

pprForAllType :: Monad m => TypePrec -> Type -> m ClashDoc
pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty

pprSigmaType :: Monad m => Bool -> Type -> m ClashDoc
pprSigmaType showForalls ty = do
    (tvs, rho)     <- split1 [] ty
    sep <$> sequenceA [ if showForalls then pprForAll tvs else pure emptyDoc
                      , pprType rho
                      ]
  where
    split1 tvs (ForAllTy tv resTy) = split1 (tv:tvs) resTy
    split1 tvs resTy               = return (reverse tvs,resTy)

pprForAll :: Monad m => [TyVar] -> m ClashDoc
pprForAll []  = return emptyDoc
pprForAll tvs = do
  tvs' <- mapM pprTvBndr tvs
  return $ forall_ <+> sep tvs' <> dot

pprTvBndr :: Monad m => TyVar -> m ClashDoc
pprTvBndr tv = do
  tv'   <- pprM tv
  kind' <- pprKind (varType tv)
  return $ tyParens $ tv' <> (annotate (AnnSyntax Type) $ space <> dcolon <+> kind')

pprKind :: Monad m => Kind -> m ClashDoc
pprKind = pprType

pprTcApp :: Monad m => TypePrec -> (TypePrec -> Type -> m ClashDoc)
  -> TyConName -> [Type] -> m ClashDoc
pprTcApp p pp tc tys
  | null tys
  = pprM tc

  | isTupleTyConLike tc
  = do tys' <- mapM (pp TopPrec) tys
       return $ parens $ sep $ punctuate comma tys'

  | isSym
  , [ty1, ty2] <- tys
  = do ty1' <- pp FunPrec ty1
       ty2' <- pp FunPrec ty2
       tc' <- pprM tc
       return $ maybeParen p FunPrec $
         sep [ty1', enclose "`" "`" tc' <+> ty2']

  | otherwise
  = do tys' <- mapM (pp TyConPrec) tys
       tc' <- parensIf isSym <$> pprM tc
       return $ maybeParen p TyConPrec $
         hang 2 $ sep (tc':tys')

  where isSym = isSymName tc

isSymName :: Name a -> Bool
isSymName n = go (nameOcc n)
  where
    go s | T.null s           = False
         | isUpper $ T.head s = isLexConSym s
         | otherwise          = isLexSym s

isLexSym :: Text -> Bool
isLexSym cs = isLexConSym cs || isLexVarSym cs

isLexConSym :: Text -> Bool
isLexConSym "->" = True
isLexConSym cs   = startsConSym (T.head cs)

isLexVarSym :: Text -> Bool
isLexVarSym cs = startsVarSym (T.head cs)

startsConSym :: Char -> Bool
startsConSym c = c == ':'

startsVarSym :: Char -> Bool
startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c)

isSymbolASCII :: Char -> Bool
isSymbolASCII c = c `elem` ("!#$%&*+./<=>?@\\^|~-" :: String)