diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 102 |
1 files changed, 51 insertions, 51 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 40d630b0..c7ae15ca 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -41,7 +41,6 @@ import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) -import Outputable ( panic ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -65,7 +64,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigType lty) fixities splice unicode pkg qual + (hsSigTypeI lty) fixities splice unicode pkg qual ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml @@ -152,8 +151,8 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype + do_args n leader (HsForAllTy _ fvf tvs ltype) + = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -219,7 +218,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> 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] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -306,8 +305,8 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod , Nothing , [] ) - ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" - ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" + ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec + ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec -- | Print a pseudo family declaration @@ -332,7 +331,7 @@ ppFamHeader :: Bool -- ^ is a summary -> Bool -- ^ is an associated type -> FamilyDecl DocNameI -- ^ family declaration -> Unicode -> Qualification -> Html -ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" +ppFamHeader _ _ (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader summary associated (FamilyDecl { fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity @@ -372,7 +371,7 @@ 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 - XFamilyResultSig _ -> panic "haddock:ppResultSig" + XFamilyResultSig nec -> noExtCon nec -------------------------------------------------------------------------------- @@ -497,7 +496,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc noHtml doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -548,31 +547,26 @@ ppClassDecl summary links instances fixities loc d subdocs , let name = unL . fdLName $ unL at doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities - defTys = ppDefaultAssocTy name <$> lookupDAT name + defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name ] -- Default associated types - ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl - splice unicode pkg qual - where - synDecl = SynDecl { tcdSExt = noExt - , tcdLName = noLoc n - , tcdTyVars = vs - , tcdFixity = GHC.Prefix - , tcdRhs = t } + 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, doc)) - | L _ (FamEqn { feqn_rhs = typ - , feqn_tycon = L _ name - , feqn_pats = vs }) <- atsDefs - , let doc = noDocForDecl -- TODO: get docs for associated type defaults + [ (getName name, (vs, typ)) + | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }))) <- atsDefs ] -- Methods methodBit = subMethods - [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ) + [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs) @@ -587,7 +581,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") - d' [n] (hsSigType t) [] splice unicode pkg qual + d' [n] (hsSigTypeI t) [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList @@ -777,7 +771,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigTypeI typ) ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -823,7 +817,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNames (unLoc c)))) fixities + (map unLoc (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual @@ -888,10 +882,10 @@ ppShortConstrParts summary dataInst con unicode qual , noHtml , noHtml ) - XConDecl {} -> panic "haddock:ppShortConstrParts" + XConDecl nec -> noExtCon nec where - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -908,10 +902,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) - aConName = unLoc (head (getConNames con)) + aConName = unLoc (head (getConNamesI con)) fixity = ppFixities fixities qual - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) @@ -957,7 +951,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - XConDecl{} -> panic "haddock:ppSideBySideConstr" + XConDecl nec -> noExtCon nec fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -986,11 +980,11 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts - XConDecl{} -> panic "haddock:doConstrArgsWithDocs" + XConDecl nec -> noExtCon nec -- 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 (unLoc $ head $ getConNames con) subdocs >>= + mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1005,7 +999,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml - | otherwise = ppForAllPart unicode qual tvs + | otherwise = ppForAllPart unicode qual tvs ForallInvis ppCtxt | null ctxt = noHtml @@ -1030,14 +1024,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = -- 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 (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst -ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" +ppSideBySideField _ _ _ (XConDeclField nec) = noExtCon nec ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" +ppShortField _ _ _ (XConDeclField nec) = noExtCon nec -- | Pretty print an expanded pattern (for bundled patterns) @@ -1060,7 +1054,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigTypeI typ) , fixity ] @@ -1070,7 +1064,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigType typ + patTy = hsSigTypeI typ emptyCtxt = patSigContext patTy @@ -1144,7 +1138,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) -ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" +ppHsTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) @@ -1159,16 +1153,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp hasNonEmptyContext :: LHsType name -> Bool 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 + HsForAllTy _ _ _ s -> hasNonEmptyContext s + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of - HsForAllTy _ _ s -> isFirstContextEmpty s - HsQualTy _ cxt _ -> null (unLoc cxt) - HsFunTy _ _ s -> isFirstContextEmpty s + HsForAllTy _ _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ s -> isFirstContextEmpty s _ -> False @@ -1178,16 +1172,22 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html -ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot + +ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html +ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv + where + tvs' = ppTyVars unicode qual tvs + fv = case fvf of + ForallVis -> spaceHtml +++ arrow unicode + ForallInvis -> dot 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 _ tvs ty) unicode qual emptyCtxts - = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts +ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts |