diff options
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 11 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 135 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 222 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 35 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/InterfaceFile.hs | 8 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Options.hs | 5 |
8 files changed, 255 insertions, 165 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index acb2c892..f8494242 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -144,7 +144,7 @@ spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) = -- A Haskell line comment then case span (/= '\n') str' of (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest) - (_, _) -> (str, "") + (_, _) -> (str, "") -- An actual Haskell token else let (str'', rest) = spanToNewline 0 str' @@ -165,10 +165,10 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) go :: (RealSrcLoc, [T.Token], Bool) -- ^ current position, tokens accumulated, currently in pragma (or not) - + -> (Located L.Token, String) -- ^ next token, its content - + -> (RealSrcLoc, [T.Token], Bool) -- ^ new position, new tokens accumulated, currently in pragma (or not) @@ -179,12 +179,12 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) ) where (next_pos, white) = mkWhitespace pos l - + classifiedTok = [ Token (classify' tok) raw rss | RealSrcSpan rss <- [l] , not (null raw) ] - + classify' | in_prag = const TkPragma | otherwise = classify @@ -378,6 +378,7 @@ classify tok = ITLarrowtail {} -> TkGlyph ITRarrowtail {} -> TkGlyph + ITcomment_line_prag -> TkUnknown ITunknown {} -> TkUnknown ITeof -> TkUnknown diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4a3e9d03..0c7747bd 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -12,10 +12,9 @@ -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.LaTeX ( - ppLaTeX + ppLaTeX, ) where - import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils @@ -285,7 +284,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode + TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now @@ -303,12 +302,6 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of unicode = False -ppTyFam :: Bool -> Documentation DocName -> - TyClDecl DocNameI -> Bool -> LaTeX -ppTyFam _ _ _ _ = - error "type family declarations are currently not supported by --latex" - - ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = ppFunSig doc [name] (hsSigType typ) unicode @@ -317,6 +310,83 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" ------------------------------------------------------------------------------- +-- * Type families +------------------------------------------------------------------------------- + +-- | Pretty-print a data\/type family declaration +ppFamDecl :: Documentation DocName -- ^ this decl's docs + -> [DocInstance DocNameI] -- ^ relevant instances + -> TyClDecl DocNameI -- ^ family to print + -> Bool -- ^ unicode + -> LaTeX +ppFamDecl doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + where + body = catMaybes [familyEqns, documentationToLaTeX doc] + + whereBit = case fdInfo (tcdFam decl) of + ClosedTypeFamily _ -> keyword "where" + _ -> empty + + familyEqns + | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + = Just (text "\\haddockbeginargs" $$ + vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ + text "\\end{tabulary}\\par") + | otherwise = Nothing + + -- Individual equations of a closed type family + ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX + ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts } }) + = hsep [ ppAppNameTypes n (map unLoc ts) unicode + , equals + , ppType unicode (unLoc rhs) + ] + ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" + ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" + + instancesBit = ppDocInstances unicode instances + +-- | Print the LHS of a type\/data family declaration. +ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print + -> Bool -- ^ unicode + -> LaTeX +ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" +ppFamHeader (FamilyDecl { fdLName = L _ name + , fdTyVars = tvs + , fdInfo = info + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) + unicode = + leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + where + leader = case info of + OpenTypeFamily -> keyword "type" + ClosedTypeFamily _ -> keyword "type" + DataFamily -> keyword "data" + + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) + + famSig = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr + XFamilyResultSig _ -> panic "haddock:ppFamHeader" + + injAnn = case injectivity of + Nothing -> empty + Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|") + : ppLDocName lhs + : arrow unicode + : map ppLDocName rhs) + + + +------------------------------------------------------------------------------- -- * Type Synonyms ------------------------------------------------------------------------------- @@ -538,12 +608,14 @@ ppClassDecl instances doc subdocs | otherwise = error "LaTeX.ppClassDecl" methodTable = - text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode + text "\\haddockpremethods{}" <> emph (text "Methods") $$ + vcat [ ppFunSig doc names (hsSigWcType typ) unicode | L _ (TypeSig _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - ] + , 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? instancesBit = ppDocInstances unicode instances @@ -573,14 +645,13 @@ ppDocInstance unicode (instHead, doc, _, _) = ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX -ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead - - -ppInstHead :: Bool -> InstHead DocNameI -> LaTeX -ppInstHead unicode (InstHead {..}) = case ihdInstType of - ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ - TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs - DataInst _ -> error "data instances not supported by --latex yet" +ppInstDecl unicode (InstHead {..}) = case ihdInstType of + ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ + TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs + DataInst dd -> + let nd = dd_ND (tcdDataDefn dd) + pref = case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" } + in pref <+> keyword "instance" <+> typ where typ = ppAppNameTypes ihdClsName ihdTypes unicode tibody = maybe empty (\t -> equals <+> ppType unicode t) @@ -613,7 +684,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = cons = dd_cons (tcdDataDefn dataDecl) resTy = (unLoc . head) cons - body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX] + body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit] (whereBit, leaders) | null cons @@ -823,6 +894,12 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument" -- * Type applications -------------------------------------------------------------------------------- +ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX +ppAppDocNameTyVarBndrs unicode n vs = + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) + where + ppDN = ppBinder . nameOccName . getName + -- | Print an application of a DocName to its list of HsTypes ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX @@ -897,7 +974,7 @@ tupleParens _ = parenList sumParens :: [LaTeX] -> LaTeX -sumParens = ubxparens . hsep . punctuate (text " | ") +sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- @@ -917,6 +994,12 @@ ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode +ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX +ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name +ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind +ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" + ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) @@ -973,7 +1056,7 @@ ppr_mono_ty (HsParTy _ ty) unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_' +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_" ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1252,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" +ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index cc271fef..12e65716 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -15,9 +15,7 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Decl ( ppDecl, - - ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances, - tyvarNames + ppOrphanInstances, ) where import Haddock.Backends.Xhtml.DocMarkup @@ -56,7 +54,7 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual + TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual @@ -67,7 +65,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml - _ -> error "declaration not supported by ppDecl" + _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> @@ -222,9 +220,6 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs -tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit - ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] @@ -283,111 +278,111 @@ ppSimpleSig links splice unicode qual emptyCtxts loc names typ = -------------------------------------------------------------------------------- -ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html -ppFamilyInfo assoc OpenTypeFamily - | assoc = keyword "type" - | otherwise = keyword "type family" -ppFamilyInfo assoc DataFamily - | assoc = keyword "data" - | otherwise = keyword "data family" -ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" - - -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI - -> Unicode -> Qualification -> Html -ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdResultSig = L _ result - , fdInjectivityAnn = injectivity }) - unicode qual = - (case info of - OpenTypeFamily - | associated -> keyword "type" - | otherwise -> keyword "type family" - DataFamily - | associated -> keyword "data" - | otherwise -> keyword "data family" - ClosedTypeFamily _ - -> keyword "type family" - ) <+> - - ppFamDeclBinderWithVars summary unicode qual d <+> - ppResultSig result unicode qual <+> - - (case injectivity of - Nothing -> noHtml - Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn - ) <+> - - (case info of - ClosedTypeFamily _ -> keyword "where ..." - _ -> mempty - ) -ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" - -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 - XFamilyResultSig _ -> panic "haddock:ppResultSig" - -ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI - -> Html -ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = - ppFamilyInfo True pfdInfo <+> - ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+> - ppResultSig (unLoc pfdKindSig) unicode qual - -ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html -ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = - char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> - hsep (map (ppLDocName qual Raw) rhs) - - -ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] -> - [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocNameI -> Splice -> Unicode -> Maybe Package -> - Qualification -> Html -ppTyFam summary associated links instances fixities loc doc decl splice unicode - pkg qual - - | summary = ppTyFamHeader True associated decl unicode qual +-- | 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 Nothing pkg qual doc +++ instancesBit where docname = unLoc $ fdLName decl header_ = topDeclElem links loc splice [docname] $ - ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual + ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual instancesBit | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl , not summary - = subEquations pkg qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns + = 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 - ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl - ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs - , feqn_pats = ts } }) - = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual + ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl + ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts } }) + = ( ppAppNameTypes n (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) - , Nothing, [] ) - ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" - ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" - + , Nothing + , [] + ) + ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl" + ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl" -ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification - -> PseudoFamilyDecl DocNameI - -> Html -ppPseudoFamilyDecl links splice unicode qual - decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = - wrapper $ ppPseudoFamilyHeader unicode qual decl +-- | 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 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 _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" +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 - wrapper = topDeclElem links loc splice [name] + 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) + +-- | 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 + XFamilyResultSig _ -> panic "haddock:ppResultSig" -------------------------------------------------------------------------------- @@ -399,25 +394,10 @@ 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 = - ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode pkg qual + ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual -------------------------------------------------------------------------------- --- * TyClDecl helpers --------------------------------------------------------------------------------- - --- | Print a type family and its variables -ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html -ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = - ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" - --- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html -ppDataBinderWithVars summ unicode qual decl = - ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) - --------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- @@ -672,7 +652,9 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m , mdoc , [subFamInstDetails iid pdecl mname]) where - pdata = keyword "data" <+> typ + 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 @@ -684,9 +666,7 @@ ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification -> [PseudoFamilyDecl DocNameI] -> [Html] ppInstanceAssocTys links splice unicode qual = - map ppFamilyDecl' - where - ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual + map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual) ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification @@ -1060,10 +1040,12 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = -- | 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 decl@(DataDecl { tcdDataDefn = - HsDataDefn { dd_ND = nd - , dd_ctxt = ctxt - , dd_kindSig = ks } }) +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" }) @@ -1071,7 +1053,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = -- context ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b - ppDataBinderWithVars summary unicode qual decl + ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs) <+> case ks of Nothing -> mempty Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x @@ -1120,7 +1102,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 _) = error "haddock:ppHsTyVarBndr" +ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 7fbaec6d..62781fd0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -183,7 +183,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" dcolon, arrow, darrow, forallSymbol :: Bool -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6eee353b..f8c26175 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -36,9 +36,10 @@ import TyCon import Type import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey - , tYPETyConKey, liftedRepDataConKey ) +import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName + , unitTy, promotedNilDataCon, promotedConsDataCon ) +import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey + , liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut , splitAtList ) @@ -118,8 +119,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType rhs - in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs - , hsib_closed = True } + in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name , feqn_pats = annot_typats @@ -457,9 +457,24 @@ synifyType _ (TyConApp tc tys) ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = + | getName tc == listTyConName, [ty] <- vis_tys = noLoc $ HsListTy noExt (synifyType WithinType ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLoc $ HsExplicitListTy noExt Promoted [] + | tc == promotedConsDataCon + , [ty1, ty2] <- vis_tys + = let hTy = synifyType WithinType ty1 + in case synifyType WithinType ty2 of + tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy + -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy') + | otherwise + -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys @@ -567,6 +582,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k +stripKindSig :: LHsType GhcRn -> LHsType GhcRn +stripKindSig (L _ (HsKindSig _ t _)) = t +stripKindSig t = t + synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls @@ -652,8 +671,8 @@ tcSplitSigmaTyPreserveSynonyms ty = tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) tcSplitForAllTysPreserveSynonyms ty = split ty ty [] where - split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1c976410..351a39d1 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -23,7 +23,7 @@ import GHC hiding (NoLink) import Name import Outputable ( panic ) import RdrName (RdrName(Exact)) -import PrelNames (eqTyCon_RDR) +import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Monad hiding (mapM) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index ce6ecc78..30bd2b9a 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) +#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] @@ -190,8 +190,9 @@ readInterfaceFile :: forall m. MonadIO m => NameCacheAccessor m -> FilePath + -> Bool -- ^ Disable version check. Can cause runtime crash. -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do +readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do bh0 <- liftIO $ readBinMem filename magic <- liftIO $ get bh0 @@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do case () of _ | magic /= binaryInterfaceMagic -> return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + | not bypass_checks + , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $ "Interface file is of wrong version: " ++ filename | otherwise -> with_name_cache $ \update_nc -> do diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index b5e987d8..46db572b 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -84,6 +84,7 @@ data Flag | Flag_Version | Flag_CompatibleInterfaceVersions | Flag_InterfaceVersion + | Flag_BypassInterfaceVersonCheck | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String @@ -175,6 +176,8 @@ options backwardsCompat = "output compatible interface file versions and exit", Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) "output interface file version and exit", + Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck) + "bypass the interface file version check (dangerous)", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") @@ -186,7 +189,7 @@ options backwardsCompat = Option [] ["gen-index"] (NoArg Flag_GenIndex) "generate an HTML index from specified\ninterfaces", Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", + "behave as if all modules have the\nignore-exports attribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") |