main/PprTyThing.hs

    -----------------------------------------------------------------------------
    --
    -- Pretty-printing TyThings
    --
    -- (c) The GHC Team 2005
    --
    -----------------------------------------------------------------------------

    {-# 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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
    -- for details

    module PprTyThing (
    	pprTyThing,
    	pprTyThingInContext,
    	pprTyThingLoc,
    	pprTyThingInContextLoc,
    	pprTyThingHdr,
      	pprTypeForUser
      ) where

    import TypeRep ( TyThing(..) )
    import DataCon
    import Id
    import TyCon
    import Class
    import Coercion( pprCoAxBranch )
    import CoAxiom( CoAxiom(..), brListMap )
    import HscTypes( tyThingParent_maybe )
    import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )
    import Kind( synTyConResKind )
    import TypeRep( pprTvBndrs, pprForAll, suppressKinds )
    import TysPrim( alphaTyVars )
    import MkIface ( tyThingToIfaceDecl )
    import TcType
    import Name
    import VarEnv( emptyTidyEnv )
    import StaticFlags( opt_PprStyle_Debug )
    import DynFlags
    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 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 = []

    showSub :: NamedThing n => ShowSub -> n -> Bool
    showSub []    _     = True
    showSub (n:_) thing = n == getName thing

    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

    ----------------------------
    -- | Pretty-prints a 'TyThing' with its defining location.
    pprTyThingLoc :: TyThing -> SDoc
    pprTyThingLoc tyThing
      = showWithLoc (pprDefinedAt (getName tyThing)) (pprTyThing tyThing)

    -- | Pretty-prints a 'TyThing'.
    pprTyThing :: TyThing -> SDoc
    pprTyThing thing = ppr_ty_thing (Just showAll) thing

    -- | 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 :: TyThing -> SDoc
    pprTyThingInContext thing
      = go [] thing
      where
        go ss thing = case tyThingParent_maybe thing of
                        Just parent -> go (getName thing : ss) parent
                        Nothing     -> ppr_ty_thing (Just ss) thing

    -- | Like 'pprTyThingInContext', but adds the defining location.
    pprTyThingInContextLoc :: TyThing -> SDoc
    pprTyThingInContextLoc tyThing
      = showWithLoc (pprDefinedAt (getName tyThing))
                    (pprTyThingInContext 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 :: TyThing -> SDoc
    pprTyThingHdr = ppr_ty_thing Nothing

    ------------------------
    -- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the
    -- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details.
    ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc
    ppr_ty_thing mss tyThing = case tyThing of
        AnId id -> pprId id
        ATyCon tyCon -> case mss of
            Nothing -> pprTyConHdr tyCon
            Just ss -> pprTyCon ss tyCon
        _ -> ppr $ tyThingToIfaceDecl tyThing

    pprTyConHdr :: TyCon -> SDoc
    pprTyConHdr tyCon
      | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
      = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
      | Just cls <- tyConClass_maybe tyCon
      = pprClassHdr cls
      | otherwise
      = sdocWithDynFlags $ \dflags ->
        ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon
        <+> pprTvBndrs (suppressKinds dflags (tyConKind tyCon) vars)
      where
        vars | isPrimTyCon tyCon ||
    	   isFunTyCon tyCon = take (tyConArity tyCon) alphaTyVars
    	 | otherwise = tyConTyVars tyCon

        keyword | isSynTyCon tyCon = sLit "type"
                | isNewTyCon tyCon = sLit "newtype"
                | otherwise        = sLit "data"

        opt_family
          | isFamilyTyCon tyCon = ptext (sLit "family")
          | otherwise             = empty

        opt_stupid 	-- The "stupid theta" part of the declaration
    	| isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon)
    	| otherwise	   = empty	-- Returns 'empty' if null theta

    pprClassHdr :: Class -> SDoc
    pprClassHdr cls
      = sdocWithDynFlags $ \dflags ->
        ptext (sLit "class") <+>
        sep [ pprThetaArrowTy (classSCTheta cls)
            , ppr_bndr cls
              <+> pprTvBndrs (suppressKinds dflags (tyConKind (classTyCon cls)) tvs)
            , pprFundeps funDeps ]
      where
         (tvs, funDeps) = classTvsFds cls

    pprId :: Var -> SDoc
    pprId ident
      = hang (ppr_bndr ident <+> dcolon)
    	 2 (pprTypeForUser (idType ident))

    pprTypeForUser :: Type -> SDoc
    -- We do two things here.
    -- a) We tidy the type, regardless
    -- b) Swizzle the foralls to the top, so that without
    --    -fprint-explicit-foralls we'll suppress all the foralls
    -- 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 ty
      = pprSigmaType (mkSigmaTy tvs ctxt tau)
      where
        (tvs, ctxt, tau) = tcSplitSigmaTy tidy_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 :: ShowSub -> TyCon -> SDoc
    pprTyCon ss tyCon
      | Just syn_rhs <- synTyConRhs_maybe tyCon
      = case syn_rhs of
          OpenSynFamilyTyCon    -> pp_tc_with_kind
          BuiltInSynFamTyCon {} -> pp_tc_with_kind

          ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches })
             -> hang closed_family_header
                  2  (vcat (brListMap (pprCoAxBranch tyCon) branches))

          AbstractClosedSynFamilyTyCon
             -> closed_family_header <+> ptext (sLit "..")

          SynonymTyCon rhs_ty
             -> hang (pprTyConHdr tyCon <+> equals)
                   2 (ppr rhs_ty)   -- Don't suppress foralls on RHS type!

                                                     -- e.g. type T = forall a. a->a
      | Just cls <- tyConClass_maybe tyCon
      = (pp_roles (== Nominal)) $$ pprClass ss cls

      | otherwise
      = (pp_roles (== Representational)) $$ pprAlgTyCon ss tyCon

      where
          -- if, for each role, suppress_if role is True, then suppress the role
          -- output
        pp_roles :: (Role -> Bool) -> SDoc
        pp_roles suppress_if
          = sdocWithDynFlags $ \dflags ->
            let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon)
            in ppUnless (isFamInstTyCon tyCon || all suppress_if roles) $
                 -- Don't display roles for data family instances (yet)
                 -- See discussion on Trac #8672.
               ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles)

        pp_tc_with_kind = vcat [ pp_roles (const True)
                               , pprTyConHdr tyCon <+> dcolon
                                 <+> pprTypeForUser (synTyConResKind tyCon) ]
        closed_family_header
           = pp_tc_with_kind <+> ptext (sLit "where")

    pprAlgTyCon :: ShowSub -> TyCon -> SDoc
    pprAlgTyCon ss tyCon
      | gadt      = pprTyConHdr tyCon <+> ptext (sLit "where") $$
    		   nest 2 (vcat (ppr_trim (map show_con datacons)))
      | otherwise = hang (pprTyConHdr tyCon)
        		   2 (add_bars (ppr_trim (map show_con datacons)))
      where
        datacons = tyConDataCons tyCon
        gadt = any (not . isVanillaDataCon) datacons

        ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
        show_con dc
          | ok_con dc = Just (pprDataConDecl ss gadt dc)
          | otherwise = Nothing

    pprDataConDecl :: ShowSub -> Bool -> DataCon -> SDoc
    pprDataConDecl ss gadt_style dataCon
      | not gadt_style = ppr_fields tys_w_strs
      | otherwise      = ppr_bndr dataCon <+> dcolon <+>
    			sep [ pp_foralls, pprThetaArrowTy theta, pp_tau ]
    	-- Printing out the dataCon as a type signature, in GADT style
      where
        (forall_tvs, theta, tau) = tcSplitSigmaTy (dataConUserType dataCon)
        (arg_tys, res_ty)        = tcSplitFunTys tau
        labels     = dataConFieldLabels dataCon
        stricts    = dataConStrictMarks dataCon
        tys_w_strs = zip (map user_ify stricts) arg_tys
        pp_foralls = sdocWithDynFlags $ \dflags ->
                     ppWhen (gopt Opt_PrintExplicitForalls dflags)
                            (pprForAll forall_tvs)

        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 <> 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_bndr lbl <+> dcolon <+> pprBangTy bty)
    	| otherwise      = Nothing

        ppr_fields [ty1, ty2]
    	| 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 :: ShowSub -> Class -> SDoc
    pprClass ss cls
      | null methods && null assoc_ts
      = pprClassHdr cls
      | otherwise
      = vcat [ pprClassHdr cls <+> ptext (sLit "where")
             , nest 2 (vcat $ ppr_trim $
                       map show_at assoc_ts ++ map show_meth methods)]
      where
        methods  = classMethods cls
        assoc_ts = classATs cls
        show_meth id | showSub ss id  = Just (pprClassMethod id)
    	         | otherwise      = Nothing
        show_at tc = case showSub_maybe ss tc of
                          Just ss' -> Just (pprTyCon ss' tc)
                          Nothing  -> Nothing

    pprClassMethod :: Id -> SDoc
    pprClassMethod id
      = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser 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 (idType id)
      (_sel_tyvars, rho_ty) = splitForAllTys tidy_sel_ty
      op_ty = 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 :: NamedThing a => a -> SDoc
    ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName 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
      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.
    -}