Add dump flag for timing output
[ghc.git] / compiler / main / PprTyThing.hs
index 6d5344d..35741b8 100644 (file)
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE CPP #-}
 module PprTyThing (
-       PrintExplicitForalls,
-       pprTyThing,
-       pprTyThingInContext, pprTyThingParent_maybe,
-       pprTyThingLoc,
-       pprTyThingInContextLoc,
-       pprTyThingHdr,
-       pprTypeForUser
+        pprTyThing,
+        pprTyThingInContext,
+        pprTyThingLoc,
+        pprTyThingInContextLoc,
+        pprTyThingHdr,
+        pprTypeForUser,
+        pprFamInst
   ) where
 
-import qualified GHC
+#include "HsVersions.h"
 
-import GHC ( TyThing(..) )
-import DataCon
-import Id
-import IdInfo
-import TyCon
-import Coercion( pprCoAxiom )
-import TcType
+import GhcPrelude
+
+import Type    ( TyThing(..) )
+import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
+  , showToHeader, pprIfaceDecl )
+import CoAxiom ( coAxiomTyCon )
+import HscTypes( tyThingParent_maybe )
+import MkIface ( tyThingToIfaceDecl )
+import Type ( tidyOpenType )
+import FamInstEnv( FamInst(..), FamFlavor(..) )
+import Type( Type, pprTypeApp, pprSigmaType )
 import Name
+import VarEnv( emptyTidyEnv )
 import Outputable
-import FastString
 
 -- -----------------------------------------------------------------------------
 -- Pretty-printing entities that we get from the GHC API
 
--- This should be a good source of sample code for using the GHC API to
--- inspect source code entities.
+{-  Note [Pretty-printing TyThings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pretty-print a TyThing by converting it to an IfaceDecl,
+and pretty-printing that (see ppr_ty_thing below).
+Here is why:
+
+* When pretty-printing (a type, say), the idiomatic solution is not to
+  "rename type variables on the fly", but rather to "tidy" the type
+  (which gives each variable a distinct print-name), and then
+  pretty-print it (without renaming). Separate the two
+  concerns. Functions like tidyType do this.
+
+* Alas, for type constructors, TyCon, tidying does not work well,
+  because a TyCon includes DataCons which include Types, which mention
+  TyCons. And tidying can't tidy a mutually recursive data structure
+  graph, only trees.
+
+* One alternative would be to ensure that TyCons get type variables
+  with distinct print-names. That's ok for type variables but less
+  easy for kind variables. Processing data type declarations is
+  already so complicated that I don't think it's sensible to add the
+  extra requirement that it generates only "pretty" types and kinds.
+
+*  One place the non-pretty names can show up is in GHCi. But another
+   is in interface files. Look at MkIface.tyThingToIfaceDecl which
+   converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it
+   already does tidying as part of that conversion!  Why? Because
+   interface files contains fast-strings, not uniques, so the names
+   must at least be distinct.
+
+So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can
+print that.  Of course, that means that pretty-printing IfaceDecls
+must be careful to display nice user-friendly results, but that's ok.
+
+See #7730, #8776 for details   -}
+
+--------------------
+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.
+pprFamInst :: FamInst -> SDoc
+--  * For data instances we go via pprTyThing of the representational TyCon,
+--    because there is already much cleverness associated with printing
+--    data type declarations that I don't want to duplicate
+--  * For type instances we print directly here; there is no TyCon
+--    to give to pprTyThing
+--
+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes
 
-type PrintExplicitForalls = Bool
+pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })
+  = pprTyThingInContextLoc (ATyCon rep_tc)
 
-type ShowMe = Name -> Bool
--- The ShowMe function says which sub-components to print
---   True  <=> print
---   False <=> elide to "..."
+pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
+                    , fi_tys = lhs_tys, fi_rhs = rhs })
+  = showWithLoc (pprDefinedAt (getName axiom)) $
+    hang (text "type instance" <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
+       2 (equals <+> ppr rhs)
 
 ----------------------------
 -- | Pretty-prints a 'TyThing' with its defining location.
-pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing
-  = showWithLoc loc (pprTyThing pefas tyThing)
-  where loc = pprNameLoc (GHC.getName tyThing)
-
--- | Pretty-prints a 'TyThing'.
-pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThing pefas thing = ppr_ty_thing pefas (const True) thing
+pprTyThingLoc :: TyThing -> SDoc
+pprTyThingLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThing showToHeader tyThing)
 
-ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc
-ppr_ty_thing pefas _    (AnId id)          = pprId         pefas id
-ppr_ty_thing pefas _    (ADataCon dataCon) = pprDataConSig pefas dataCon
-ppr_ty_thing pefas show_me (ATyCon tyCon)   = pprTyCon      pefas show_me tyCon
-ppr_ty_thing _     _       (ACoAxiom ax)    = pprCoAxiom    ax
-ppr_ty_thing pefas show_me (AClass cls)     = pprClass      pefas show_me cls
+-- | Pretty-prints the 'TyThing' header. For functions and data constructors
+-- the function is equivalent to 'pprTyThing' but for type constructors
+-- and classes it prints only the header part of the declaration.
+pprTyThingHdr :: TyThing -> SDoc
+pprTyThingHdr = pprTyThing showToHeader
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
 -- is a data constructor, record selector, or class method, then
 -- the entity's parent declaration is pretty-printed with irrelevant
 -- parts omitted.
-pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContext pefas thing
-  | Just parent <- pprTyThingParent_maybe thing
-  = ppr_ty_thing pefas (== GHC.getName thing) parent
-  | otherwise
-  = pprTyThing pefas thing
-
--- | Like 'pprTyThingInContext', but adds the defining location.
-pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContextLoc pefas tyThing
-  = showWithLoc (pprNameLoc (GHC.getName tyThing))
-                (pprTyThingInContext pefas tyThing)
-
-pprTyThingParent_maybe :: TyThing -> Maybe TyThing
--- (pprTyThingParent_maybe x) returns (Just p)
--- when pprTyThingInContext sould print a declaration for p
--- (albeit with some "..." in it) when asked to show x
-pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
-pprTyThingParent_maybe (AnId id)     = case idDetails id of
-                                        RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
-                                        ClassOpId cls               -> Just (AClass cls)
-                                        _other                      -> Nothing
-pprTyThingParent_maybe _other = Nothing
-
--- | Pretty-prints the 'TyThing' header. For functions and data constructors
--- the function is equivalent to 'pprTyThing' but for type constructors
--- and classes it prints only the header part of the declaration.
-pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingHdr pefas (AnId id)          = pprId         pefas id
-pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
-pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
-pprTyThingHdr _     (ACoAxiom ax)      = pprCoAxiom ax
-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 tys
-  | otherwise
-  = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
+pprTyThingInContext :: ShowSub -> TyThing -> SDoc
+pprTyThingInContext show_sub thing
+  = go [] thing
   where
-    vars | GHC.isPrimTyCon 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"
-
-    opt_family
-      | GHC.isFamilyTyCon tyCon = ptext (sLit "family")
-      | otherwise             = empty
-
-    opt_stupid         -- The "stupid theta" part of the declaration
-       | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
-       | otherwise        = empty      -- Returns 'empty' if null theta
-
-pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
-pprDataConSig pefas dataCon
-  = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon)
-
-pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
-pprClassHdr _ cls
-  = ptext (sLit "class") <+>
-    GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
-    ppr_bndr cls <+>
-    hsep (map ppr tyVars) <+>
-    GHC.pprFundeps funDeps
-  where
-     (tyVars, funDeps) = GHC.classTvsFds cls
-
-pprId :: PrintExplicitForalls -> Var -> SDoc
-pprId pefas ident
-  = hang (ppr_bndr ident <+> dcolon)
-        2 (pprTypeForUser pefas (GHC.idType ident))
+    go ss thing
+      = case tyThingParent_maybe thing of
+          Just parent ->
+            go (getOccName thing : ss) parent
+          Nothing ->
+            pprTyThing
+              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })
+              thing
 
-pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
--- We do two things here.
--- a) We tidy the type, regardless
--- b) If PrintExplicitForAlls is True, we discard the foralls
---     but we do so `deeply'
--- Prime example: a class op might have type
---     forall a. C a => forall b. Ord b => stuff
--- Then we want to display
---     (C a, Ord b) => stuff
-pprTypeForUser print_foralls ty
-  | print_foralls = ppr tidy_ty
-  | otherwise     = ppr (mkPhiTy ctxt ty')
-  where
-    tidy_ty     = tidyTopType ty
-    (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
-
-pprTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
-pprTyCon pefas show_me tyCon
-  | GHC.isSynTyCon tyCon
-  = if GHC.isFamilyTyCon tyCon
-    then pprTyConHdr pefas tyCon <+> dcolon <+> 
-        pprTypeForUser pefas (GHC.synTyConResKind tyCon)
-    else
-      let rhs_type = GHC.synTyConType tyCon
-      in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
-  | otherwise
-  = pprAlgTyCon pefas show_me tyCon
-
-pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
-pprAlgTyCon pefas show_me tyCon
-  | 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))
-  where
-    datacons = GHC.tyConDataCons tyCon
-    gadt = any (not . GHC.isVanillaDataCon) datacons
-
-    ok_con dc = show_me (dataConName dc) || any show_me (dataConFieldLabels dc)
-    show_con dc
-      | ok_con dc = Just (pprDataConDecl pefas show_me gadt dc)
-      | otherwise = Nothing
-
-pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
-pprDataConDecl pefas show_me gadt_style dataCon
-  | not gadt_style = ppr_fields tys_w_strs
-  | otherwise      = ppr_bndr dataCon <+> dcolon <+>
-                       sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
-       -- Printing out the dataCon as a type signature, in GADT style
-  where
-    (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
-    (arg_tys, res_ty)        = tcSplitFunTys tau
-    labels     = GHC.dataConFieldLabels dataCon
-    stricts    = GHC.dataConStrictMarks dataCon
-    tys_w_strs = zip stricts arg_tys
-    pp_foralls | pefas     = GHC.pprForAll forall_tvs
-               | otherwise = empty
-
-    pp_tau = foldr add (ppr res_ty) tys_w_strs
-    add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
-
-    pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
-
-    pprBangTy bang ty = ppr bang <> ppr ty
-
-    maybe_show_label (lbl,(strict,tp))
-       | show_me lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
-       | otherwise   = Nothing
-
-    ppr_fields [ty1, ty2]
-       | GHC.dataConIsInfix dataCon && null labels
-       = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
-    ppr_fields fields
-       | null labels
-       = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
-       | otherwise
-       = ppr_bndr dataCon <+>
-               braces (sep (punctuate comma (ppr_trim maybe_show_label
-                                       (zip labels fields))))
-
-pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
-pprClass pefas show_me cls
-  | null methods
-  = pprClassHdr pefas cls
-  | otherwise
-  = hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
-       2 (vcat (ppr_trim show_meth methods))
-  where
-    methods = GHC.classMethods cls
-    show_meth id | show_me (idName id) = Just (pprClassMethod pefas id)
-                | otherwise           = Nothing
+-- | Like 'pprTyThingInContext', but adds the defining location.
+pprTyThingInContextLoc :: TyThing -> SDoc
+pprTyThingInContextLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThingInContext showToHeader tyThing)
 
-pprClassMethod :: PrintExplicitForalls -> Id -> SDoc
-pprClassMethod pefas id
-  = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty)
+-- | Pretty-prints a 'TyThing'.
+pprTyThing :: ShowSub -> TyThing -> SDoc
+-- We pretty-print 'TyThing' via 'IfaceDecl'
+-- See Note [Pretty-printing TyThings]
+pprTyThing ss ty_thing
+  = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing)
   where
-  -- Here's the magic incantation to strip off the dictionary
-  -- from the class op type.  Stolen from IfaceSyn.tyThingToIfaceDecl.
-  --
-  -- It's important to tidy it *before* splitting it up, so that if
-  -- we have   class C a b where
-  --             op :: forall a. a -> b
-  -- then the inner forall on op gets renamed to a1, and we print
-  -- (when dropping foralls)
-  --           class C a b where
-  --             op :: a1 -> b
-
-  tidy_sel_ty = tidyTopType (GHC.idType id)
-  (_sel_tyvars, rho_ty) = GHC.splitForAllTys tidy_sel_ty
-  op_ty = GHC.funResultTy rho_ty
-
-ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
-ppr_trim show xs
-  = snd (foldr go (False, []) xs)
+    ss' = case ss_how_much ss of
+      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }
+      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }
+      _                   -> ss
+
+    ppr' = AltPpr $ ppr_bndr $ getName ty_thing
+
+    ppr_bndr :: Name -> Maybe (OccName -> SDoc)
+    ppr_bndr name
+      | isBuiltInSyntax name
+         = Nothing
+      | otherwise
+         = case nameModule_maybe name of
+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->
+               pprModulePrefix sty mod occ <> ppr occ
+             Nothing  -> WARN( True, ppr name ) Nothing
+             -- Nothing is unexpected here; TyThings have External names
+
+pprTypeForUser :: Type -> SDoc
+-- The type is tidied
+pprTypeForUser ty
+  = pprSigmaType tidy_ty
   where
-    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)
-
-add_bars :: [SDoc] -> SDoc
-add_bars []      = empty
-add_bars [c]     = equals <+> c
-add_bars (c:cs)  = sep ((equals <+> c) : map (char '|' <+>) cs)
-
--- Wrap operators in ()
-ppr_bndr :: GHC.NamedThing a => a -> SDoc
-ppr_bndr a = GHC.pprParenSymName a
+    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty
+     -- Often the types/kinds we print in ghci are fully generalised
+     -- and have no free variables, but it turns out that we sometimes
+     -- print un-generalised kinds (eg when doing :k T), so it's
+     -- better to use tidyOpenType here
 
 showWithLoc :: SDoc -> SDoc -> SDoc
 showWithLoc loc doc
     = hang doc 2 (char '\t' <> comment <+> loc)
-               -- The tab tries to make them line up a bit
+                -- The tab tries to make them line up a bit
   where
-    comment = ptext (sLit "--")
-
+    comment = text "--"