Fix Trac #3966: warn about useless UNPACK pragmas

[ghc-hetmet.git] / compiler / main / PprTyThing.hs

diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index e57122b..dfa713f 100644 (file)
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -16,17 +16,15 @@ module PprTyThing (
        pprTypeForUser
   ) where
 
-#include "HsVersions.h"
-
 import qualified GHC
 
 import GHC ( TyThing(..) )
 import TyCon
-import Type ( TyThing(..), tidyTopType, pprTypeApp )
 import TcType
 import Var
 import Name
 import Outputable
+import FastString
 
 -- -----------------------------------------------------------------------------
 -- Pretty-printing entities that we get from the GHC API
@@ -77,7 +75,7 @@ pprTyThingHdr pefas (AClass cls)       = pprClassHdr   pefas cls
 pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
 pprTyConHdr _ tyCon
   | Just (_fam_tc, tys) <- tyConFamInst_maybe tyCon
-  = ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
+  = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon tys
   | otherwise
   = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
@@ -85,12 +83,12 @@ pprTyConHdr _ tyCon
           GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
         | otherwise = GHC.tyConTyVars tyCon
 
-    keyword | GHC.isSynTyCon tyCon = SLIT("type")
-            | GHC.isNewTyCon tyCon = SLIT("newtype")
-            | otherwise            = SLIT("data")
+    keyword | GHC.isSynTyCon tyCon = sLit "type"
+            | GHC.isNewTyCon tyCon = sLit "newtype"
+            | otherwise            = sLit "data"
 
     opt_family
-      | GHC.isOpenTyCon tyCon = ptext SLIT("family")
+      | GHC.isOpenTyCon tyCon = ptext (sLit "family")
       | otherwise             = empty
 
     opt_stupid         -- The "stupid theta" part of the declaration
@@ -104,7 +102,7 @@ pprDataConSig pefas dataCon =
 pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
 pprClassHdr _ cls =
   let (tyVars, funDeps) = GHC.classTvsFds cls
-  in ptext SLIT("class") <+> 
+  in ptext (sLit "class") <+> 
      GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
      ppr_bndr cls <+>
      hsep (map ppr tyVars) <+>
@@ -160,7 +158,7 @@ pprTyCon pefas tyCon
 pprAlgTyCon :: PrintExplicitForalls -> TyCon -> (GHC.DataCon -> Bool)
             -> (FieldLabel -> Bool) -> SDoc
 pprAlgTyCon pefas tyCon ok_con ok_label
-  | gadt      = pprTyConHdr pefas tyCon <+> ptext SLIT("where") $$ 
+  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ 
                   nest 2 (vcat (ppr_trim show_con datacons))
   | otherwise = hang (pprTyConHdr pefas tyCon)
                   2 (add_bars (ppr_trim show_con datacons))
@@ -192,20 +190,16 @@ pprDataConDecl _ gadt_style show_label dataCon
 
     ppr_tvs 
        | null qualVars = empty
-       | otherwise     = ptext SLIT("forall") <+> 
+       | otherwise     = ptext (sLit "forall") <+> 
                                hsep (map ppr qualVars) <> dot
 
        -- printing out the dataCon as a type signature, in GADT style
     pp_tau = foldr add (ppr res_ty) tys_w_strs
     add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
 
-    pprParendBangTy (strict,ty)
-       | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty
-       | otherwise                 = GHC.pprParendType ty
+    pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
 
-    pprBangTy strict ty
-       | GHC.isMarkedStrict strict = char '!' <> ppr ty
-       | otherwise                 = ppr ty
+    pprBangTy bang ty = ppr bang <> ppr ty
 
     maybe_show_label (lbl,(strict,tp))
        | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
@@ -213,7 +207,7 @@ pprDataConDecl _ gadt_style show_label dataCon
 
     ppr_fields [ty1, ty2]
        | GHC.dataConIsInfix dataCon && null labels
-       = sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2]
+       = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
     ppr_fields fields
        | null labels
        = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
@@ -227,14 +221,14 @@ pprClass pefas cls
   | null methods = 
        pprClassHdr pefas cls
   | otherwise = 
-       hang (pprClassHdr pefas cls <+> ptext SLIT("where"))
+       hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
            2 (vcat (map (pprClassMethod pefas) methods))
   where
        methods = GHC.classMethods cls
 
 pprClassOneMethod :: PrintExplicitForalls -> GHC.Class -> Id -> SDoc
 pprClassOneMethod pefas cls this_one
-  = hang (pprClassHdr pefas cls <+> ptext SLIT("where"))
+  = hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
         2 (vcat (ppr_trim show_meth methods))
   where
        methods = GHC.classMethods cls
@@ -267,7 +261,7 @@ ppr_trim show xs
     go x (eliding, so_far)
        | Just doc <- show x = (False, doc : so_far)
        | otherwise = if eliding then (True, so_far)
-                                else (True, ptext SLIT("...") : so_far)
+                                else (True, ptext (sLit "...") : so_far)
 
 add_bars :: [SDoc] -> SDoc
 add_bars []      = empty
@@ -283,5 +277,5 @@ showWithLoc loc doc
     = hang doc 2 (char '\t' <> comment <+> loc)
                -- The tab tries to make them line up a bit
   where
-    comment = ptext SLIT("--")
+    comment = ptext (sLit "--")