{-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl -- Copyright : (c) Simon Marlow 2003-2006, -- David Waern 2006-2009, -- Mark Lentczner 2010 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Decl ( ppDecl, ppOrphanInstances, ) where import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) import GHC.Core.Type ( Specificity(..) ) import GHC hiding (LexicalFixity(..), fromMaybeContext) import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula import GHC.Types.Name.Reader ( rdrNameOcc ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only -> LinksInfo -- ^ link information -> LHsDecl DocNameI -- ^ declaration to print -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant pattern synonyms -> DocForDecl DocName -- ^ documentation for this decl -> [DocInstance DocNameI] -- ^ relevant instances -> [(DocName, Fixity)] -- ^ relevant fixities -> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls -> Splice -> Unicode -- ^ unicode output -> Maybe Package -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames (dropWildCards lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames lty fixities splice unicode pkg qual ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLSigType unicode qual HideEmptyContexts typ -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [LocatedN DocName] -- ^ names of patterns in declaration -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ) where pp_typ = ppPatSigType unicode qual typ ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) splice unicode pkg qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html | summary = html | otherwise = html <+> ppFixities fixities qual ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode pkg qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) +++ docSection curname pkg qual doc where curname = getName <$> listToMaybe docnames -- | This splits up a type signature along @->@ and adds docs (when they exist) -- to the arguments. -- -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when -- we expand an `HsRecTy`) -> Html -> HideEmptyContexts -> [SubDecl] ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ where do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl] do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = case outer_bndrs of HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype HsOuterImplicit{} -> do_largs n leader ltype where leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs) argDoc n = Map.lookup n argDocs do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy _ tele ltype) = do_largs n leader' ltype where leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (ldr <+> html, mdoc, subs) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r do_args n leader (HsFunTy _ _w lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] -- FIXME: this should be done more elegantly -- -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" gadtOpen = toHtml "{" ppFixities :: [(DocName, Fixity)] -> Qualification -> Html ppFixities [] _ = noHtml ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge where ppFix (ns, p, d) = thespan ! [theclass "fixity"] << (toHtml d <+> toHtml (show p) <+> ppNames ns) ppDir InfixR = "infixr" ppDir InfixL = "infixl" ppDir InfixN = "infix" ppNames = case fs of _:[] -> const noHtml -- Don't display names for fixities on single names _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs , let d' = ppDir d , then group by Down (p,d') using groupWith ] rightEdge = thespan ! [theclass "rightedge"] << noHtml -- | Pretty-print type variables. ppTyVars :: RenderableBndrFlag flag => Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode pkg qual = ppTypeOrFunSig summary links loc [name] sig_type doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode pkg qual ShowEmptyToplevelContexts where sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml | otherwise = ppFixities fixities qual ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html ppTypeSig summary nms pp_ty unicode = concatHtml htmlNames <+> dcolon unicode <+> pp_ty where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsSigType DocNameI -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice ppTyp = ppSigType unicode qual emptyCtxts typ occNames = map getOccName names -------------------------------------------------------------------------------- -- * Type families -------------------------------------------------------------------------------- -- | Print a data\/type family declaration ppFamDecl :: Bool -- ^ is a summary -> Bool -- ^ is an associated type -> LinksInfo -> [DocInstance DocNameI] -- ^ relevant instances -> [(DocName, Fixity)] -- ^ relevant fixities -> SrcSpan -> Documentation DocName -- ^ this decl's documentation -> FamilyDecl DocNameI -- ^ this decl -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual | summary = ppFamHeader True associated decl unicode qual | otherwise = header_ +++ docSection curname pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl curname = Just $ getName docname header_ = topDeclElem links loc splice [docname] $ ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary = subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns | otherwise = ppInstances links (OriginFamily docname) instances splice unicode pkg qual -- Individual equation of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl ppFamDeclEqn (FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts }) = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing , [] ) -- | Print a pseudo family declaration ppPseudoFamDecl :: LinksInfo -> Splice -> PseudoFamilyDecl DocNameI -- ^ this decl -> Unicode -> Qualification -> Html ppPseudoFamDecl links splice (PseudoFamilyDecl { pfdInfo = info , pfdKindSig = L _ kindSig , pfdTyVars = tvs , pfdLName = L loc name }) unicode qual = topDeclElem links (locA loc) splice [name] leader where leader = hsep [ ppFamilyLeader True info , ppAppNameTypes name (map unLoc tvs) unicode qual , ppResultSig kindSig unicode qual ] -- | Print the LHS of a type\/data family declaration ppFamHeader :: Bool -- ^ is a summary -> Bool -- ^ is an associated type -> FamilyDecl DocNameI -- ^ family declaration -> Unicode -> Qualification -> Html ppFamHeader summary associated (FamilyDecl { fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity , fdLName = L _ name , fdTyVars = tvs }) unicode qual = hsep [ ppFamilyLeader associated info , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs) , ppResultSig result unicode qual , injAnn , whereBit ] where whereBit = case info of ClosedTypeFamily _ -> keyword "where ..." _ -> noHtml injAnn = case injectivity of Nothing -> noHtml Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|" : ppLDocName qual Raw lhs : arrow unicode : map (ppLDocName qual Raw) rhs) Just _ -> error "ppFamHeader:XInjectivityAnn" -- | Print the keywords that begin the family declaration ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family") where typ = case info of OpenTypeFamily -> "type" ClosedTypeFamily _ -> "type" DataFamily -> "data" -- | Print the signature attached to a family ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of NoSig _ -> noHtml KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr -------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix ppBinderFixity _ = ppBinder -- | Print an application of a 'DocName' to its list of 'HsType's ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html ppAppNameTypes n ts unicode qual = ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts) ppAppNameTypeArgs n args u q = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args) -- | General printing of type applications ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- ppLContext :: Maybe (LHsContext DocNameI) -> Unicode -> Qualification -> HideEmptyContexts -> Html ppLContext Nothing u q h = ppContext [] u q h ppLContext (Just c) u q h = ppContext (unLoc c) u q h ppLContextNoArrow :: LHsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $ ppContextNoLocsMaybe cxt unicode qual emptyCtxts ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html ppContextNoLocsMaybe [] _ _ emptyCtxts = case emptyCtxts of HideEmptyContexts -> Nothing ShowEmptyToplevelContexts -> Just (toHtml "()") ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html ppHsContext [] _ _ = noHtml ppHsContext [p] unicode qual = ppCtxType unicode qual p ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt) ------------------------------------------------------------------------------- -- * Class declarations ------------------------------------------------------------------------------- ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 fundep (XFunDep _) = error "ppFds" ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs splice unicode pkg qual = if not (any isUserLSig sigs) && null ats then (if summary then id else topDeclElem links loc splice [nm]) hdr else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults [ ppFunSig summary links loc noHtml doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that -- there are different subdocs for different names in a single -- type signature? ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual nm = unLoc lname ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where curname = Just $ getName nm sigs = map unLoc lsigs classheader | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual nm = tcdNameI decl hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- Associated types atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual <+> subDefaults (maybeToList defTys) | at <- ats , let name = unLoc . fdLName $ unLoc at doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name ] -- Default associated types ppDefaultAssocTy n (vs,rhs) = hsep [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals , ppType unicode qual HideEmptyContexts (unLoc rhs) ] lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ)) | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ , feqn_tycon = L _ name , feqn_pats = vs })) <- atsDefs ] -- Methods methodBit = subMethods [ ppFunSig summary links loc noHtml doc [name] typ subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs) | ClassOpSig _ False lnames typ <- sigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities defSigs = ppDefaultFunSig name <$> lookupDM name ] -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") d' [n] t [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList [ (nameStr, (typ, doc)) | ClassOpSig _ True lnames typ <- sigs , name <- map unLoc lnames , let doc = noDocForDecl -- TODO: get docs for method defaults nameStr = getOccString name ] -- Minimal complete definition minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing And [] : _ -> subMinimal $ toHtml "Nothing" m : _ -> subMinimal $ ppMinimal False m _ -> noHtml ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppInstances :: LinksInfo -> InstOrigin DocName -> [DocInstance DocNameI] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppInstances links origin instances splice unicode pkg qual = subInstances pkg qual instName links True (zipWith instDecl [1..] instances) -- force Splice = True to use line URLs where instName = getOccString origin instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) = ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc) ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppOrphanInstances links instances splice unicode pkg qual = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances) where instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) = ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification -> Maybe (MDoc DocName) -> InstOrigin DocName -> Bool -- ^ Is instance orphan -> Int -- ^ Normal -> InstHead DocNameI -> Maybe Module -> SubDecl ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl = case ihdInstType of ClassInst { .. } -> ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc , [subInstDetails iid ats sigs mname] ) where sigs = ppInstanceSigs links splice unicode qual clsiSigs ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> ( subInstHead iid ptype , mdoc , [subFamInstDetails iid prhs mname] ) where ptype = keyword "type" <+> typ prhs = ptype <+> maybe noHtml (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs DataInst dd -> ( subInstHead iid pdata , mdoc , [subFamInstDetails iid pdecl mname]) where nd = dd_ND (tcdDataDefn dd) pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" } pdata = pref <+> typ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdTypes unicode qual ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification -> [PseudoFamilyDecl DocNameI] -> [Html] ppInstanceAssocTys links splice unicode qual = map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual) ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do TypeSig _ lnames typ <- sigs let names = map unLoc lnames L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String instanceId origin no orphan ihd = concat $ [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin , ":" ++ getOccString (ihdClsName ihd) , ":" ++ show no ] where qual (OriginClass _) = "ic" qual (OriginData _) = "id" qual (OriginFamily _) = "if" ------------------------------------------------------------------------------- -- * Data & newtype declarations ------------------------------------------------------------------------------- -- TODO: print contexts ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI -> [(HsDecl DocNameI, DocForDecl DocName)] -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl pats unicode qual | [] <- cons , [] <- pats = dataHeader | [lcon] <- cons, [] <- pats, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot | [] <- pats, isH98 = dataHeader +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1) | otherwise = (dataHeader <+> keyword "where") +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1) where dataHeader | dataInst = noHtml | otherwise = ppDataHeader summary dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode , ppPatSigType unicode qual typ ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] -- | Pretty-print a data declaration ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -- ^ relevant instances -> [(DocName, Fixity)] -- ^ relevant fixities -> [(DocName, DocForDecl DocName)] -- ^ all decl documentation -> SrcSpan -> Documentation DocName -- ^ this decl's documentation -> TyClDecl DocNameI -- ^ this decl -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode pkg qual | summary = ppShortDataDecl summary False dataDecl pats unicode qual | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdNameI dataDecl curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual whereBit | null cons , null pats = noHtml | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors pkg qual [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unL (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual [ ppSideBySidePat subfixs unicode qual lnames typ d | (SigD _ (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] instancesBit = ppInstances links (OriginData docname) instances splice unicode pkg qual ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon _ args -> ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> ( header_ +++ ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] , char '}' ) -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) ] , noHtml , noHtml ) -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT {} -> ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] , noHtml , noHtml ) where occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) -- | Pretty print an expanded constructor ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -- ^ constructor declaration to print -> SubDecl ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) = ( decl -- Constructor header (name, fixity) , mbDoc -- Docs on the whole constructor , fieldPart -- Information on the fields (or arguments, if they have docs) ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) aConName = unL (head (getConNamesI con)) fixity = ppFixities fixities qual occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) -- Extract out the map of of docs corresponding to the constructors arguments argDocs = maybe Map.empty snd (lookup aConName subdocs) hasArgDocs = not $ Map.null argDocs decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars , con_forall = forall_ , con_mb_cxt = cxt } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , fixity ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon _ -> header_ <+> ppOcc <+> fixity -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) , fixity ] -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT{} | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] fieldPart = case con of ConDeclGADT{con_g_args = con_args'} -> case con_args' of -- GADT record declarations RecConGADT _ _ -> [ doConstrArgsWithDocs [] ] -- GADT prefix data constructors PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] _ -> [] ConDeclH98{con_args = con_args'} -> case con_args' of -- H98 record declarations RecCon (L _ fields) -> [ doRecordFields fields ] -- H98 prefix data constructors PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ] -- H98 infix data constructor InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) doConstrArgsWithDocs args = subFields pkg qual $ case con of ConDeclH98{} -> [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) | (i, arg) <- zip [0..] (map hsScaledThing args) , let mdoc = Map.lookup i argDocs ] ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml | otherwise = ppForAllPart unicode qual (HsForAllInvis noExtField tvs) ppCtxt | null ctxt = noHtml | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode +++ toHtml " " -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) | L _ name <- names , let field = (unLoc . foLabel) name ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype , mbDoc , [] ) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -- | Pretty print an expanded pattern (for bundled patterns) ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification -> [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> SubDecl ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = ( decl , combineDocumentation doc , fieldPart ) where hasArgDocs = not $ Map.null argDocs fixity = ppFixities fixities qual ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames)) decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode , ppPatSigType unicode qual typ , fixity ] fieldPart | not hasArgDocs = [] | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) argDocs [] (dcolon unicode) emptyCtxt) ] emptyCtxt = patSigContext typ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html ppDataHeader summary (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd , dd_ctxt = ctxt , dd_kindSig = ks } , tcdLName = L _ name , tcdTyVars = tvs }) unicode qual = -- newtype or data (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs) <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Types and contexts -------------------------------------------------------------------------------- ppBang :: HsSrcBang -> Html ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" ppBang _ = noHtml tupleParens :: HsTupleSort -> [Html] -> Html tupleParens HsUnboxedTuple = ubxParenList tupleParens _ = parenList sumParens :: [Html] -> Html sumParens = ubxSumList -------------------------------------------------------------------------------- -- * Rendering of HsType -------------------------------------------------------------------------------- ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y) ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode qual emptyCtxts ki ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" class RenderableBndrFlag flag where ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html instance RenderableBndrFlag () where ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) instance RenderableBndrFlag Specificity where ppHsTyVarBndr _ qual (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts patSigContext :: LHsSigType DocNameI -> HideEmptyContexts patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts | otherwise = HideEmptyContexts where typ = sig_body (unLoc sig_typ) hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s HsQualTy _ cxt _ -> null (unLoc cxt) HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value) ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ ppHsOuterTyVarBndrs :: RenderableBndrFlag flag => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of HsOuterImplicit{} -> noHtml HsOuterExplicit{hso_bndrs = bndrs} -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of HsForAllVis { hsf_vis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ spaceHtml +++ arrow unicode HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | isPromoted prom = promoQuote (ppDocName q Prefix True name) | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of HsLinearArrow _ -> lollipop u HsUnrestrictedArrow _ -> arrow u HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsKindSig _ ty kind) u q e = ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _ = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ] ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts] ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where ppr_op_prom | isPromoted prom = promoQuote ppr_op | otherwise = ppr_op ppr_op = ppLDocName qual Infix op ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts = parens (ppr_mono_lty ty unicode qual emptyCtxts) -- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts = ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit DocNameI -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) ppr_tylit (HsCharTy _ c) = toHtml (show c)