Add dump flag for timing output
[ghc.git] / compiler / main / PprTyThing.hs
index c14b853..35741b8 100644 (file)
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
+{-# LANGUAGE CPP #-}
 module PprTyThing (
-       PrintExplicitForalls,
-       pprTyThing,
-       pprTyThingInContext, 
-       pprTyThingLoc,
-       pprTyThingInContextLoc,
-       pprTyThingHdr,
-       pprTypeForUser
+        pprTyThing,
+        pprTyThingInContext,
+        pprTyThingLoc,
+        pprTyThingInContextLoc,
+        pprTyThingHdr,
+        pprTypeForUser,
+        pprFamInst
   ) where
 
-import qualified GHC
+#include "HsVersions.h"
+
+import GhcPrelude
 
-import GHC ( TyThing(..) )
-import DataCon
-import Id
-import TyCon
-import Coercion( pprCoAxiom )
+import Type    ( TyThing(..) )
+import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
+  , showToHeader, pprIfaceDecl )
+import CoAxiom ( coAxiomTyCon )
 import HscTypes( tyThingParent_maybe )
-import Type( tidyTopType, tidyOpenType )
-import TcType
+import MkIface ( tyThingToIfaceDecl )
+import Type ( tidyOpenType )
+import FamInstEnv( FamInst(..), FamFlavor(..) )
+import Type( Type, pprTypeApp, pprSigmaType )
 import Name
 import VarEnv( emptyTidyEnv )
-import StaticFlags( opt_PprStyle_Debug )
 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.
-
-type PrintExplicitForalls = Bool
-
-type ShowSub = [Name]
---   []     <=> print all sub-components of the current thing
---   (n:ns) <=> print sub-component 'n' with ShowSub=ns
---              elide other sub-components to "..."
-showAll :: ShowSub
-showAll = []
+{-  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
 
-showSub :: NamedThing n => ShowSub -> n -> Bool
-showSub []    _     = True
-showSub (n:_) thing = n == getName thing
+pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })
+  = pprTyThingInContextLoc (ATyCon rep_tc)
 
-showSub_maybe :: NamedThing n => ShowSub -> n -> Maybe ShowSub
-showSub_maybe []     _     = Just []
-showSub_maybe (n:ns) thing = if n == getName thing then Just ns
-                                                   else Nothing
+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 (pprDefinedAt (GHC.getName tyThing)) (pprTyThing pefas tyThing)
+pprTyThingLoc :: TyThing -> SDoc
+pprTyThingLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThing showToHeader tyThing)
 
--- | Pretty-prints a 'TyThing'.
-pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThing pefas thing = ppr_ty_thing pefas showAll thing
+-- | 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
+pprTyThingInContext :: ShowSub -> TyThing -> SDoc
+pprTyThingInContext show_sub thing
   = go [] thing
   where
-    go ss thing = case tyThingParent_maybe thing of
-                    Just parent -> go (getName thing : ss) parent
-                    Nothing     -> ppr_ty_thing pefas ss thing
+    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
 
 -- | Like 'pprTyThingInContext', but adds the defining location.
-pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingInContextLoc pefas tyThing
-  = showWithLoc (pprDefinedAt (GHC.getName tyThing))
-                (pprTyThingInContext pefas tyThing)
-
--- | 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
-
-------------------------
-ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc
-ppr_ty_thing pefas _  (AnId id)          = pprId         pefas id
-ppr_ty_thing pefas _  (ADataCon dataCon) = pprDataConSig pefas dataCon
-ppr_ty_thing pefas ss (ATyCon tyCon)            = pprTyCon      pefas ss tyCon
-ppr_ty_thing _     _  (ACoAxiom ax)             = pprCoAxiom    ax
-pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
-pprTyConHdr pefas tyCon
-  | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
-  = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
-  | Just cls <- tyConClass_maybe tyCon
-  = pprClassHdr pefas cls
-  | otherwise
-  = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
-  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
+pprTyThingInContextLoc :: TyThing -> SDoc
+pprTyThingInContextLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThingInContext showToHeader tyThing)
 
-    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
+-- | 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
-     (tyVars, funDeps) = GHC.classTvsFds cls
-
-pprId :: PrintExplicitForalls -> Var -> SDoc
-pprId pefas ident
-  = hang (ppr_bndr ident <+> dcolon)
-        2 (pprTypeForUser pefas (GHC.idType ident))
-
-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')
+    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
-    (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
-    (_, tidy_ty)   = tidyOpenType emptyTidyEnv ty
+    (_, 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
 
-pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
-pprTyCon pefas ss tyCon
-  | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon
-  = case syn_rhs of
-      SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> 
-                           pprTypeForUser pefas (GHC.synTyConResKind tyCon)
-      SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 
-                                2 (pprTypeForUser pefas rhs_ty)
-
-  | Just cls <- GHC.tyConClass_maybe tyCon
-  = pprClass pefas ss cls
-  | otherwise
-  = pprAlgTyCon pefas ss tyCon
-
-pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
-pprAlgTyCon pefas ss tyCon
-  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
-                  nest 2 (vcat (ppr_trim (map show_con datacons)))
-  | otherwise = hang (pprTyConHdr pefas tyCon)
-                  2 (add_bars (ppr_trim (map show_con datacons)))
-  where
-    datacons = GHC.tyConDataCons tyCon
-    gadt = any (not . GHC.isVanillaDataCon) datacons
-
-    ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
-    show_con dc
-      | ok_con dc = Just (pprDataConDecl pefas ss gadt dc)
-      | otherwise = Nothing
-
-pprDataConDecl :: PrintExplicitForalls -> ShowSub -> Bool -> GHC.DataCon -> SDoc
-pprDataConDecl pefas ss 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 (map user_ify 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
-
-    -- See Note [Printing bangs on data constructors]
-    user_ify :: HsBang -> HsBang
-    user_ify bang | opt_PprStyle_Debug = bang
-    user_ify HsStrict                  = HsUserBang Nothing     True
-    user_ify (HsUnpack {})             = HsUserBang (Just True) True
-    user_ify bang                      = bang
-
-    maybe_show_label (lbl,bty)
-       | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty)
-       | 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 $
-               map maybe_show_label (zip labels fields))
-
-pprClass :: PrintExplicitForalls -> ShowSub -> GHC.Class -> SDoc
-pprClass pefas ss cls
-  | null methods && null assoc_ts
-  = pprClassHdr pefas cls
-  | otherwise
-  = vcat [ pprClassHdr pefas cls <+> ptext (sLit "where")
-         , nest 2 (vcat $ ppr_trim $ 
-                   map show_at assoc_ts ++ map show_meth methods)]
-  where
-    methods  = GHC.classMethods cls
-    assoc_ts = GHC.classATs cls
-    show_meth id | showSub ss id  = Just (pprClassMethod pefas id)
-                | otherwise      = Nothing
-    show_at tc = case showSub_maybe ss tc of
-                      Just ss' -> Just (pprTyCon pefas ss' tc)
-                      Nothing  -> Nothing
-
-pprClassMethod :: PrintExplicitForalls -> Id -> SDoc
-pprClassMethod pefas id
-  = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty)
-  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 :: [Maybe SDoc] -> [SDoc]
--- Collapse a group of Nothings to a single "..."
-ppr_trim xs
-  = snd (foldr go (False, []) xs)
-  where
-    go (Just doc) (_,     so_far) = (False, doc : so_far)
-    go Nothing    (True,  so_far) = (True, so_far)
-    go Nothing    (False, so_far) = (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
-
 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 "--")
-
-{- 
-Note [Printing bangs on data constructors] 
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For imported data constructors the dataConStrictMarks are the
-representation choices (see Note [Bangs on data constructor arguments]
-in DataCon.lhs). So we have to fiddle a little bit here to turn them
-back into user-printable form.
--}
+    comment = text "--"