Reexport Semigroup's <> operator from Prelude (#14191)
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Ppr.hs
index 3f79920..bbb73b0 100644 (file)
@@ -10,19 +10,21 @@ import Text.PrettyPrint (render)
 import Language.Haskell.TH.PprLib
 import Language.Haskell.TH.Syntax
 import Data.Word ( Word8 )
-import Data.Char ( toLower, chr, ord, isSymbol )
+import Data.Char ( toLower, chr)
 import GHC.Show  ( showMultiLineString )
+import GHC.Lexeme( startsVarSym )
 import Data.Ratio ( numerator, denominator )
+import Prelude hiding ((<>))
 
 nestDepth :: Int
 nestDepth = 4
 
 type Precedence = Int
 appPrec, unopPrec, opPrec, noPrec :: Precedence
-appPrec = 3    -- Argument of a function application
-opPrec  = 2    -- Argument of an infix operator
-unopPrec = 1   -- Argument of an unresolved infix operator
-noPrec  = 0    -- Others
+appPrec  = 3    -- Argument of a function application
+opPrec   = 2    -- Argument of an infix operator
+unopPrec = 1    -- Argument of an unresolved infix operator
+noPrec   = 0    -- Others
 
 parensIf :: Bool -> Doc -> Doc
 parensIf True d = parens d
@@ -59,6 +61,7 @@ instance Ppr Info where
       = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
     ppr (DataConI v ty tc)
       = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
+    ppr (PatSynI nm ty) = pprPatSynSig nm ty
     ppr (TyVarI v ty)
       = text "Type variable" <+> ppr v <+> equals <+> ppr ty
     ppr (VarI v ty mb_d)
@@ -75,6 +78,24 @@ pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
           ppr_fix InfixL = text "infixl"
           ppr_fix InfixN = text "infix"
 
+-- | Pretty prints a pattern synonym type signature
+pprPatSynSig :: Name -> PatSynType -> Doc
+pprPatSynSig nm ty
+  = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty
+
+-- | Pretty prints a pattern synonym's type; follows the usual
+-- conventions to print a pattern synonym type compactly, yet
+-- unambiguously. See the note on 'PatSynType' and the section on
+-- pattern synonyms in the GHC user's guide for more information.
+pprPatSynType :: PatSynType -> Doc
+pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
+  | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')
+  | null uniTys, null reqs  = noreqs <+> ppr ty'
+  | null reqs               = forall uniTys <+> noreqs <+> ppr ty'
+  | otherwise               = ppr ty
+  where noreqs     = text "() =>"
+        forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."
+pprPatSynType ty            = ppr ty
 
 ------------------------------
 instance Ppr Module where
@@ -95,12 +116,9 @@ isSymOcc :: Name -> Bool
 isSymOcc n
   = case nameBase n of
       []    -> True  -- Empty name; weird
-      (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c)
+      (c:_) -> startsVarSym c
                    -- c.f. OccName.startsVarSym in GHC itself
 
-isSymbolASCII :: Char -> Bool
-isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
-
 pprInfixExp :: Exp -> Doc
 pprInfixExp (VarE v) = pprName' Infix v
 pprInfixExp (ConE v) = pprName' Infix v
@@ -112,6 +130,8 @@ pprExp _ (ConE c)     = pprName' Applied c
 pprExp i (LitE l)     = pprLit i l
 pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
                                               <+> pprExp appPrec e2
+pprExp i (AppTypeE e t)
+ = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t
 pprExp _ (ParensE e)  = parens (pprExp noPrec e)
 pprExp i (UInfixE e1 op e2)
  = parensIf (i > unopPrec) $ pprExp unopPrec e1
@@ -124,13 +144,15 @@ pprExp i (InfixE (Just e1) op (Just e2))
 pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
                                     <+> pprInfixExp op
                                     <+> pprMaybeExp noPrec me2
+pprExp i (LamE [] e) = pprExp i e -- #13856
 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
                                            <+> text "->" <+> ppr e
 pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                        $ text "\\case" $$ nest nestDepth (ppr ms)
 pprExp _ (TupE es) = parens (commaSep es)
 pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
--- Nesting in Cond is to avoid potential problems in do statments
+pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
+-- Nesting in Cond is to avoid potential problems in do statements
 pprExp i (CondE guard true false)
  = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
                        nest 1 $ text "then" <+> ppr true,
@@ -159,12 +181,17 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
 
 pprExp _ (CompE []) = text "<<Empty CompExp>>"
 -- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) = text "[" <> ppr s
-                  <+> text "|"
-                  <+> commaSep ss'
-                   <> text "]"
-    where s = last ss
-          ss' = init ss
+pprExp _ (CompE ss) =
+    if null ss'
+       -- If there are no statements in a list comprehension besides the last
+       -- one, we simply treat it like a normal list.
+       then text "[" <> ppr s <> text "]"
+       else text "[" <> ppr s
+        <+> bar
+        <+> commaSep ss'
+         <> text "]"
+  where s = last ss
+        ss' = init ss
 pprExp _ (ArithSeqE d) = ppr d
 pprExp _ (ListE es) = brackets (commaSep es)
 pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t
@@ -173,6 +200,7 @@ pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
 pprExp i (StaticE e) = parensIf (i >= appPrec) $
                          text "static"<+> pprExp appPrec e
 pprExp _ (UnboundVarE v) = pprName' Applied v
+pprExp _ (LabelE s) = text "#" <> text s
 
 pprFields :: [(Name,Exp)] -> Doc
 pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
@@ -186,7 +214,7 @@ instance Ppr Stmt where
     ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
     ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
     ppr (NoBindS e) = ppr e
-    ppr (ParS sss) = sep $ punctuate (text "|")
+    ppr (ParS sss) = sep $ punctuate bar
                          $ map commaSep sss
 
 ------------------------------
@@ -197,8 +225,8 @@ instance Ppr Match where
 ------------------------------
 pprGuarded :: Doc -> (Guard, Exp) -> Doc
 pprGuarded eqDoc (guard, expr) = case guard of
-  NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr
-  PatG    stmts     -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$
+  NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr
+  PatG    stmts     -> bar <+> vcat (punctuate comma $ map ppr stmts) $$
                          nest nestDepth (eqDoc <+> ppr expr)
 
 ------------------------------
@@ -247,6 +275,7 @@ pprPat i (LitP l)     = pprLit i l
 pprPat _ (VarP v)     = pprName' Applied v
 pprPat _ (TupP ps)    = parens (commaSep ps)
 pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
+pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
 pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
                                               <+> sep (map (pprPat appPrec) ps)
 pprPat _ (ParensP p)  = parens $ pprPat noPrec p
@@ -290,7 +319,8 @@ ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
 ppr_dec _  (ClassD ctxt c xs fds ds)
   = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
     $$ where_clause ds
-ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
+ppr_dec _ (InstanceD o ctxt i ds) =
+        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
                                   $$ where_clause ds
 ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
 ppr_dec _ (ForeignD f)  = ppr f
@@ -329,31 +359,58 @@ ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
   where
     ppr_eqn (TySynEqn lhs rhs)
       = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
-
 ppr_dec _ (RoleAnnotD name roles)
   = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
-
-ppr_dec _ (StandaloneDerivD cxt ty)
-  = hsep [ text "deriving instance", pprCxt cxt, ppr ty ]
-
+ppr_dec _ (StandaloneDerivD ds cxt ty)
+  = hsep [ text "deriving"
+         , maybe empty ppr_deriv_strategy ds
+         , text "instance"
+         , pprCxt cxt
+         , ppr ty ]
 ppr_dec _ (DefaultSigD n ty)
   = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
-
-ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc
+ppr_dec _ (PatSynD name args dir pat)
+  = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS
+  where
+    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2
+                | otherwise                 = ppr name <+> ppr args
+    pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
+                                           nestDepth (ppr name <+> ppr cls)
+                | otherwise            = ppr pat
+ppr_dec _ (PatSynSigD name ty)
+  = pprPatSynSig name ty
+
+ppr_deriv_strategy :: DerivStrategy -> Doc
+ppr_deriv_strategy ds = text $
+  case ds of
+    StockStrategy    -> "stock"
+    AnyclassStrategy -> "anyclass"
+    NewtypeStrategy  -> "newtype"
+
+ppr_overlap :: Overlap -> Doc
+ppr_overlap o = text $
+  case o of
+    Overlaps      -> "{-# OVERLAPS #-}"
+    Overlappable  -> "{-# OVERLAPPABLE #-}"
+    Overlapping   -> "{-# OVERLAPPING #-}"
+    Incoherent    -> "{-# INCOHERENT #-}"
+
+ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
+         -> Doc
 ppr_data maybeInst ctxt t argsDoc ksig cs decs
   = sep [text "data" <+> maybeInst
             <+> pprCxt ctxt
-            <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere,
+            <+> pprName' Applied t <+> argsDoc <+> ksigDoc <+> maybeWhere,
          nest nestDepth (sep (pref $ map ppr cs)),
          if null decs
            then empty
            else nest nestDepth
-              $ text "deriving" <+> ppr_cxt_preds decs]
+              $ vcat $ map ppr_deriv_clause decs]
   where
     pref :: [Doc] -> [Doc]
     pref xs | isGadtDecl = xs
     pref []              = []      -- No constructors; can't happen in H98
-    pref (d:ds)          = (char '=' <+> d):map (char '|' <+>) ds
+    pref (d:ds)          = (char '=' <+> d):map (bar <+>) ds
 
     maybeWhere :: Doc
     maybeWhere | isGadtDecl = text "where"
@@ -370,7 +427,8 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
                 Nothing -> empty
                 Just k  -> dcolon <+> ppr k
 
-ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc
+ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
+            -> Doc
 ppr_newtype maybeInst ctxt t argsDoc ksig c decs
   = sep [text "newtype" <+> maybeInst
             <+> pprCxt ctxt
@@ -379,12 +437,17 @@ ppr_newtype maybeInst ctxt t argsDoc ksig c decs
          if null decs
            then empty
            else nest nestDepth
-                $ text "deriving" <+> ppr_cxt_preds decs]
+                $ vcat $ map ppr_deriv_clause decs]
   where
     ksigDoc = case ksig of
                 Nothing -> empty
                 Just k  -> dcolon <+> ppr k
 
+ppr_deriv_clause :: DerivClause -> Doc
+ppr_deriv_clause (DerivClause ds ctxt)
+  = text "deriving" <+> maybe empty ppr_deriv_strategy ds
+                    <+> ppr_cxt_preds ctxt
+
 ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
 ppr_tySyn maybeInst t argsDoc rhs
   = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
@@ -400,7 +463,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
 instance Ppr FunDep where
     ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
     ppr_list [] = empty
-    ppr_list xs = char '|' <+> commaSep xs
+    ppr_list xs = bar <+> commaSep xs
 
 ------------------------------
 instance Ppr FamFlavour where
@@ -416,7 +479,7 @@ instance Ppr FamilyResultSig where
 ------------------------------
 instance Ppr InjectivityAnn where
     ppr (InjectivityAnn lhs rhs) =
-        char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
+        bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
 
 ------------------------------
 instance Ppr Foreign where
@@ -467,6 +530,9 @@ instance Ppr Pragma where
             target1 (ValueAnnotation v) = ppr v
     ppr (LineP line file)
        = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
+    ppr (CompleteP cls mty)
+       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)
+                <+> maybe empty (\ty -> dcolon <+> ppr ty) mty
 
 ------------------------------
 instance Ppr Inline where
@@ -523,13 +589,28 @@ instance Ppr Con where
     ppr (RecGadtC c vsts ty)
         = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty
 
+instance Ppr PatSynDir where
+  ppr Unidir        = text "<-"
+  ppr ImplBidir     = text "="
+  ppr (ExplBidir _) = text "<-"
+    -- the ExplBidir's clauses are pretty printed together with the
+    -- entire pattern synonym; so only print the direction here.
+
+instance Ppr PatSynArgs where
+  ppr (PrefixPatSyn args) = sep $ map ppr args
+  ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2
+  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))
+
 commaSepApplied :: [Name] -> Doc
 commaSepApplied = commaSepWith (pprName' Applied)
 
 pprForall :: [TyVarBndr] -> Cxt -> Doc
-pprForall ns ctxt
-    = text "forall" <+> hsep (map ppr ns)
-  <+> char '.' <+> pprCxt ctxt
+pprForall tvs cxt
+  -- even in the case without any tvs, there could be a non-empty
+  -- context cxt (e.g., in the case of pattern synonyms, where there
+  -- are multiple forall binders and contexts).
+  | [] <- tvs = pprCxt cxt
+  | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt
 
 pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
 pprRecFields vsts ty
@@ -599,19 +680,21 @@ pprStrictType = pprBangType
 
 ------------------------------
 pprParendType :: Type -> Doc
-pprParendType (VarT v)            = ppr v
-pprParendType (ConT c)            = ppr c
+pprParendType (VarT v)            = pprName' Applied v
+-- `Applied` is used here instead of `ppr` because of infix names (#13887)
+pprParendType (ConT c)            = pprName' Applied c
 pprParendType (TupleT 0)          = text "()"
 pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
 pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
+pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
 pprParendType ArrowT              = parens (text "->")
 pprParendType ListT               = text "[]"
 pprParendType (LitT l)            = pprTyLit l
-pprParendType (PromotedT c)       = text "'" <> ppr c
+pprParendType (PromotedT c)       = text "'" <> pprName' Applied c
 pprParendType (PromotedTupleT 0)  = text "'()"
 pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))
 pprParendType PromotedNilT        = text "'[]"
-pprParendType PromotedConsT       = text "(':)"
+pprParendType PromotedConsT       = text "'(:)"
 pprParendType StarT               = char '*'
 pprParendType ConstraintT         = text "Constraint"
 pprParendType (SigT ty k)         = parens (ppr ty <+> text "::" <+> ppr k)
@@ -629,9 +712,7 @@ pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
 pprUInfixT t               = ppr t
 
 instance Ppr Type where
-    ppr (ForallT tvars ctxt ty)
-      = text "forall" <+> hsep (map ppr tvars) <+> text "."
-                      <+> sep [pprCxt ctxt, ppr ty]
+    ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
     ppr ty = pprTyApp (split ty)
        -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
        -- See Note [Pretty-printing kind signatures]
@@ -746,3 +827,15 @@ commaSepWith pprFun = sep . punctuate comma . map pprFun
 -- followed by space.
 semiSep :: Ppr a => [a] -> Doc
 semiSep = sep . punctuate semi . map ppr
+
+-- Prints out the series of vertical bars that wraps an expression or pattern
+-- used in an unboxed sum.
+unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc
+unboxedSumBars d alt arity = hashParens $
+    bars (alt-1) <> d <> bars (arity - alt)
+  where
+    bars i = hsep (replicate i bar)
+
+-- Text containing the vertical bar character.
+bar :: Doc
+bar = char '|'