(this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Qualification -> Doc DocName -> Html -docToHtml qual = markup fmt . cleanup +docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See + -- comments on 'toHack' for details. + -> Qualification -> MDoc DocName -> Html +docToHtml n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual True (ppDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. -docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html -docToHtmlNoAnchors qual = markup fmt . cleanup +docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' + -> Qualification -> MDoc DocName -> Html +docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) -origDocToHtml :: Qualification -> Doc Name -> Html -origDocToHtml qual = markup fmt . cleanup +origDocToHtml :: Qualification -> MDoc Name -> Html +origDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) -rdrDocToHtml :: Qualification -> Doc RdrName -> Html -rdrDocToHtml qual = markup fmt . cleanup +rdrDocToHtml :: Qualification -> MDoc RdrName -> Html +rdrDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -116,16 +219,19 @@ else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Documentation DocName -> Html -docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation +docSection :: Maybe Name -- ^ Name of the thing this doc is for + -> Qualification -> Documentation DocName -> Html +docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation -docSection_ :: Qualification -> Doc DocName -> Html -docSection_ qual = (docElement thediv <<) . docToHtml qual +docSection_ :: Maybe Name -- ^ Name of the thing this doc is for + -> Qualification -> MDoc DocName -> Html +docSection_ n qual = + (docElement thediv <<) . docToHtml (getOccString <$> n) qual -cleanup :: Doc a -> Doc a -cleanup = markup fmtUnParagraphLists +cleanup :: MDoc a -> MDoc a +cleanup = overDoc (markup fmtUnParagraphLists) where -- If there is a single paragraph, then surrounding it with
..
-- can add too much whitespace in some browsers (eg. IE). However if diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -51,7 +51,6 @@ import FastString ( unpackFS ) import GHC - -------------------------------------------------------------------------------- -- * Sections of the document -------------------------------------------------------------------------------- @@ -116,7 +115,7 @@ divTopDecl = thediv ! [theclass "top"] -type SubDecl = (Html, Maybe (Doc DocName), [Html]) +type SubDecl = (Html, Maybe (MDoc DocName), [Html]) divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html @@ -134,7 +133,7 @@ subEntry (decl, mdoc, subs) = dterm ! [theclass "src"] << decl +++ - docElement ddef << (fmap (docToHtml qual) mdoc +++ subs) + docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs) clearDiv = thediv ! [ theclass "clear" ] << noHtml @@ -146,9 +145,23 @@ subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <-> - docElement td << fmap (docToHtml qual) mdoc) + docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs +-- | Sub table with source information (optional). +subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html +subTableSrc _ _ _ _ [] = Nothing +subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls) + where + subRow ((decl, mdoc, subs),loc) = + (td ! [theclass "src"] << decl + <+> linkHtml loc + <-> + docElement td << fmap (docToHtml Nothing qual) mdoc + ) + : map (cell . (td <<)) subs + linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn + linkHtml _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing @@ -175,11 +188,15 @@ subEquations qual = divSubDecls "equations" "Equations" . subTable qual -subInstances :: Qualification -> String -> [SubDecl] -> Html -subInstances qual nm = maybe noHtml wrap . instTable +-- | Generate sub table for instance declarations, with source +subInstances :: Qualification + -> String -- ^ Class name, used for anchor generation + -> LinksInfo -> Bool -> DocName + -> [(SubDecl,SrcSpan)] -> Html +subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm @@ -199,12 +216,19 @@ -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html -topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = - declElem << (html <+> srcLink <+> wikiLink) +topDeclElem lnks loc splice names html = + declElem << (html <+> (links lnks loc splice $ head names)) + -- FIXME: is it ok to simply take the first name? + +-- | Adds a source and wiki link at the right hand side of the box. +-- Name must be documented, otherwise we wouldn't get here. +links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) = + (srcLink <+> wikiLink) where srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl - -- Use the lineUrl as a backup + -- Use the lineUrl as a backup | otherwise = maybe lineUrl Just nameUrl in case mUrl of Nothing -> noHtml @@ -224,12 +248,9 @@ -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n - origPkg = modulePackageId origMod - - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = head names - -- FIXME: is it ok to simply take the first name? + origPkg = modulePackageKey origMod fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) - UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "links: UnhelpfulSpan" +links _ _ _ _ = noHtml diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs --- a/src/Haddock/Backends/Xhtml/Types.hs +++ b/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -16,35 +16,36 @@ -- Some other functions turned out to be useful for converting -- instance heads, which aren't TyThings, so just export everything. - -import HsSyn -import TcType ( tcSplitSigmaTy ) -import TypeRep -import Type(isStrLitTy) -import Kind ( splitKindFunTys, synTyConResKind, isKind ) -import Name -import Var +import Bag ( emptyBag ) +import BasicTypes ( TupleSort(..) ) import Class -import TyCon import CoAxiom import ConLike +import Data.Either (lefts, rights) +import Data.List( partition ) import DataCon -import PatSyn import FamInstEnv -import BasicTypes ( TupleSort(..) ) +import Haddock.Types +import HsSyn +import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Name +import PatSyn +import PrelNames (ipClassName) +import SrcLoc ( Located, noLoc, unLoc, noSrcSpan ) +import TcType ( tcSplitSigmaTy ) +import TyCon +import Type (isStrLitTy, mkFunTys) +import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) -import PrelNames (ipClassName) -import Bag ( emptyBag ) import Unique ( getUnique ) -import SrcLoc ( Located, noLoc, unLoc ) -import Data.List( partition ) -import Haddock.Types +import Var + -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> LHsDecl Name -tyThingToLHsDecl t = noLoc $ case t of +tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) +tyThingToLHsDecl t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. -- foreign-imported functions could be represented with ForD @@ -53,62 +54,60 @@ -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> SigD (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a - extractFamilyDecl (FamDecl d) = noLoc d + -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) + extractFamilyDecl (FamDecl d) = return $ noLoc d extractFamilyDecl _ = - error "tyThingToLHsDecl: impossible associated tycon" + Left "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] - atFamDecls = map extractFamilyDecl atTyClDecls in - TyClD $ ClassDecl + atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] + atFamDecls = map extractFamilyDecl (rights atTyClDecls) + tyClErrors = lefts atTyClDecls + famDeclErrors = lefts atFamDecls + in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) , tcdFDs = map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ + (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: - , tcdATs = atFamDecls + , tcdATs = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNames } + , tcdFVs = placeHolderNamesTc } | otherwise - -> TyClD (synifyTyCon Nothing tc) + -> synifyTyCon Nothing tc >>= allOK . TyClD -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) - ACoAxiom ax -> synifyAxiom ax + ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc))) + AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] + (synifyType ImplicitizeForAll (dataConUserType dc)) []) AConLike (PatSynCon ps) -> -#if MIN_VERSION_ghc(7,8,3) - let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps -#else - let (_, _, (req_theta, prov_theta)) = patSynSig ps -#endif - in SigD $ PatSynSig (synifyName ps) -#if MIN_VERSION_ghc(7,8,3) - (fmap (synifyType WithinType) (patSynTyDetails ps)) - (synifyType WithinType res_ty) -#else - (fmap (synifyType WithinType) (patSynTyDetails ps)) - (synifyType WithinType (patSynType ps)) -#endif + let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps + qtvs = univ_tvs ++ ex_tvs + ty = mkFunTys arg_tys res_ty + in allOK . SigD $ PatSynSig (synifyName ps) + (Implicit, synifyTyVars qtvs) (synifyCtx req_theta) (synifyCtx prov_theta) + (synifyType WithinType ty) + where + withErrs e x = return (e, x) + allOK x = return (mempty, x) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) @@ -116,40 +115,44 @@ typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs (kvs, tvs) = partition isKindVar tkvs - in TyFamInstEqn { tfie_tycon = name - , tfie_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs } - , tfie_rhs = hs_rhs } + in TyFamEqn { tfe_tycon = name + , tfe_pats = HsWB { hswb_cts = typats + , hswb_kvs = map tyVarName kvs + , hswb_tvs = map tyVarName tvs + , hswb_wcs = [] } + , tfe_rhs = hs_rhs } -synifyAxiom :: CoAxiom br -> HsDecl Name +synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) - | isOpenSynFamilyTyCon tc + | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNames })) + = return $ InstD (TyFamInstD + (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch + , tfid_fvs = placeHolderNamesTc })) | Just ax' <- isClosedSynFamilyTyCon_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = TyClD (synifyTyCon (Just ax) tc) + = synifyTyCon (Just ax) tc >>= return . TyClD | otherwise - = error "synifyAxiom: closed/open family confusion" + = Left "synifyAxiom: closed/open family confusion" -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name +-- | Turn type constructors into type class declarations +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) synifyTyCon coax tc - | isFunTyCon tc || isPrimTyCon tc - = DataDecl { tcdLName = synifyName tc + | isFunTyCon tc || isPrimTyCon tc + = return $ + DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: - let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (getName fakeTyVar) + let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * } - - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + + , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing @@ -157,37 +160,40 @@ -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing } - , tcdFVs = placeHolderNames } + , tcdFVs = placeHolderNamesTc } - | isSynFamilyTyCon tc - = case synTyConRhs_maybe tc of + | isTypeFamilyTyCon tc + = case famTyConFlav_maybe tc of Just rhs -> let info = case rhs of - OpenSynFamilyTyCon -> OpenTypeFamily - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> - ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches) - _ -> error "synifyTyCon: type/data family confusion" - in FamDecl (FamilyDecl { fdInfo = info + OpenSynFamilyTyCon -> return OpenTypeFamily + ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> + return $ ClosedTypeFamily + (brListMap (noLoc . synifyAxBranch tc) branches) + BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily [] + AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily [] + in info >>= \i -> + return (FamDecl + (FamilyDecl { fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) }) - Nothing -> error "synifyTyCon: impossible open type synonym?" + , fdKindSig = + Just (synifyKindSig (synTyConResKind tc)) + })) + Nothing -> Left "synifyTyCon: impossible open type synonym?" - | isDataFamilyTyCon tc + | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of - DataFamilyTyCon -> + DataFamilyTyCon -> return $ FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing) --always kind '*' - _ -> error "synifyTyCon: impossible open data type?" - | isSynTyCon tc - = case synTyConRhs_maybe tc of - Just (SynonymTyCon ty) -> - SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNames } - _ -> error "synifyTyCon: impossible synTyCon" + _ -> Left "synifyTyCon: impossible open data type?" + | Just ty <- synTyConRhs_maybe tc + = return $ SynDecl { tcdLName = synifyName tc + , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdRhs = synifyType WithinType ty + , tcdFVs = placeHolderNamesTc } | otherwise = -- (closed) newtype and data let @@ -216,25 +222,29 @@ -- in prefix position), since, otherwise, the logic (at best) gets much more -- complicated. (would use dataConIsInfix.) use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) - cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) + consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) + cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig - , dd_cons = cons + , dd_cons = cons , dd_derivs = alg_deriv } - in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn - , tcdFVs = placeHolderNames } + in case lefts consRaw of + [] -> return $ + DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn + , tcdFVs = placeHolderNamesTc } + dataConErrs -> Left $ unlines dataConErrs -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> LConDecl Name -synifyDataCon use_gadt_syntax dc = noLoc $ +synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name) +synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with -- infix *syntax*. @@ -254,40 +264,41 @@ linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of - HsUnpack {} -> HsUserBang (Just True) True - HsStrict -> HsUserBang (Just False) True + HsUnpack {} -> HsSrcBang Nothing (Just True) True + HsStrict -> HsSrcBang Nothing (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn _ -> noLoc $ HsBangTy bang tySyn -- HsNoBang never appears, it's implied instead. ) - arg_tys (dataConStrictMarks dc) - field_tys = zipWith (\field synTy -> ConDeclField - (synifyName field) synTy Nothing) + arg_tys (dataConSrcBangs dc) + field_tys = zipWith (\field synTy -> noLoc $ ConDeclField + [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of - (True,True) -> error "synifyDataCon: contradiction!" - (True,False) -> RecCon field_tys - (False,False) -> PrefixCon linear_tys + (True,True) -> Left "synifyDataCon: contradiction!" + (True,False) -> return $ RecCon (noLoc field_tys) + (False,False) -> return $ PrefixCon linear_tys (False,True) -> case linear_tys of - [a,b] -> InfixCon a b - _ -> error "synifyDataCon: infix with non-2 args?" + [a,b] -> return $ InfixCon a b + _ -> Left "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax - then ResTyGADT (synifyType WithinType res_ty) + then ResTyGADT noSrcSpan (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result! - in ConDecl name Implicit{-we don't know nor care-} - qvars ctx hs_arg_tys hs_res_ty Nothing - False --we don't want any "deprecated GADT syntax" warnings! - + in hs_arg_tys >>= + \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care + qvars ctx hat hs_res_ty Nothing + -- we don't want any "deprecated GADT syntax" warnings! + False synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) +synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] synifyCtx :: [PredType] -> LHsContext Name @@ -299,9 +310,9 @@ , hsq_tvs = map synifyTyVar tvs } where (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv + synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -359,23 +370,21 @@ in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty - in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - _ -> let - forallPlicitness = case s of - WithinType -> Explicit - ImplicitizeForAll -> Implicit - _ -> error "synifyType: impossible case!!!" sTvs = synifyTyVars tvs sCtx = synifyCtx ctx sTau = synifyType WithinType tau - in noLoc $ - HsForAllTy forallPlicitness sTvs sCtx sTau + mkHsForAllTy forallPlicitness = + noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau + in case s of + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau + WithinType -> mkHsForAllTy Explicit + ImplicitizeForAll -> mkHsForAllTy Implicit + synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy n -synifyTyLit (StrTyLit s) = HsStrTy s +synifyTyLit (NumTyLit n) = HsNumTy mempty n +synifyTyLit (StrTyLit s) = HsStrTy mempty s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k @@ -390,14 +399,14 @@ where (ks,ts) = break (not . isKind) types -- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> InstHead Name +synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) synifyFamInst fi opaque = - ( fi_fam fi - , map (unLoc . synifyType WithinType) ks - , map (unLoc . synifyType WithinType) ts - , case fi_flavor fi of - SynFamilyInst | opaque -> TypeInst Nothing - SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi - DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c - ) + let fff = case fi_flavor fi of + SynFamilyInst | opaque -> return $ TypeInst Nothing + SynFamilyInst -> + return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + DataFamilyInst c -> + synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst + in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks, + map (unLoc . synifyType WithinType) ts , f') where (ks,ts) = break (not . isKind) $ fi_tys fi diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs --- a/src/Haddock/Doc.hs +++ b/src/Haddock/Doc.hs @@ -7,11 +7,14 @@ import Data.Maybe import Documentation.Haddock.Doc import Haddock.Types +import Haddock.Utils (mkMeta) -combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation :: Documentation name -> Maybe (MDoc name) combineDocumentation (Documentation Nothing Nothing) = Nothing combineDocumentation (Documentation mDoc mWarning) = - Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc) + Just (maybe emptyMetaDoc mkMeta mWarning + `metaDocAppend` + fromMaybe emptyMetaDoc mDoc) -- Drop trailing whitespace from @..@ code blocks. Otherwise this: -- diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -16,19 +16,14 @@ module Haddock.GhcUtils where -import Data.Version import Control.Applicative ( (<$>) ) import Control.Arrow -import Data.Foldable hiding (concatMap) import Data.Function -import Data.Traversable -import Distribution.Compat.ReadP -import Distribution.Text import Exception import Outputable import Name -import Packages +import Lexeme import Module import RdrName (GlobalRdrEnv) import GhcMonad (withSession) @@ -41,28 +36,6 @@ moduleString :: Module -> String moduleString = moduleNameString . moduleName - --- return the (name,version) of the package -modulePackageInfo :: Module -> (String, [Char]) -modulePackageInfo modu = case unpackPackageId pkg of - Nothing -> (packageIdString pkg, "") - Just x -> (display $ pkgName x, showVersion (pkgVersion x)) - where pkg = modulePackageId modu - - --- This was removed from GHC 6.11 --- XXX we shouldn't be using it, probably - --- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if --- we could not parse it as such an object. -unpackPackageId :: PackageId -> Maybe PackageIdentifier -unpackPackageId p - = case [ pid | (pid,"") <- readP_to_S parse str ] of - [] -> Nothing - (pid:_) -> Just pid - where str = packageIdString p - - lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of @@ -102,7 +75,7 @@ -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l + { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. @@ -114,12 +87,15 @@ filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig -filterSigNames _ orig@(MinimalSig _) = Just orig -filterSigNames p (TypeSig ns ty) = +filterSigNames p (FixSig (FixitySig ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) + filtered -> Just (FixSig (FixitySig filtered ty)) +filterSigNames _ orig@(MinimalSig _ _) = Just orig +filterSigNames p (TypeSig ns ty nwcs) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (TypeSig filtered ty nwcs) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -130,12 +106,12 @@ sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig ns _ _) = map unLoc ns +sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns +sigNameNoLoc _ = [] isTyClD :: HsDecl a -> Bool @@ -193,14 +169,6 @@ before = (<) `on` getLoc -instance Foldable (GenLocated l) where - foldMap f (L _ x) = f x - - -instance Traversable (GenLocated l) where - mapM f (L l x) = (return . L l) =<< f x - traverse f (L l x) = L l <$> f x - ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -209,11 +177,6 @@ instance NamedThing (TyClDecl Name) where getName = tcdName - -instance NamedThing (ConDecl Name) where - getName = unL . con_name - - ------------------------------------------------------------------------------- -- * Subordinates ------------------------------------------------------------------------------- @@ -226,16 +189,16 @@ instance Parent (ConDecl Name) where children con = case con_details con of - RecCon fields -> map (unL . cd_fld_name) fields + RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] - instance Parent (TyClDecl Name) where children d - | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d + | isDataDecl d = map unL $ concatMap (con_names . unL) + $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -244,11 +207,14 @@ family = getName &&& children +familyConDecl :: ConDecl Name -> [(Name, [Name])] +familyConDecl d = zip (map unL (con_names d)) (repeat $ children d) + -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. families :: TyClDecl Name -> [(Name, [Name])] families d - | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d)) + | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] @@ -301,4 +267,3 @@ -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f - diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -195,7 +195,7 @@ else n out verbosity normal coverageMsg - when (Flag_PrintMissingDocs `elem` flags + when (Flag_NoPrintMissingDocs `notElem` flags && not (null undocumentedExports && header)) $ do out verbosity normal " Missing documentation for:" unless header $ out verbosity normal " Module header" diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -18,7 +18,7 @@ import Haddock.Convert import Haddock.GhcUtils -import Control.Arrow +import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) @@ -26,6 +26,8 @@ import qualified Data.Set as Set import Class +import DynFlags +import ErrUtils import FamInstEnv import FastString import GHC @@ -34,6 +36,7 @@ import InstEnv import MonadUtils (liftIO) import Name +import Outputable (text, sep, (<+>)) import PrelNames import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy) @@ -60,32 +63,38 @@ return $ iface { ifaceExportItems = newItems } -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name) +attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap + -> ExportItem Name + -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do mb_info <- getAllInfo (tcdName d) - let export' = - e { - expItemInstances = - case mb_info of - Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, n) - | i <- sortBy (comparing instFam) fam_instances - , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap - , not $ isNameHidden expInfo (fi_fam i) - , not $ any (isTypeHidden expInfo) (fi_tys i) - , let opaque = isTypeHidden expInfo (fi_rhs i) - ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) - | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys - ] - in cls_insts ++ fam_insts - Nothing -> [] - } - return export' + insts <- case mb_info of + Just (_, _, cls_instances, fam_instances) -> + let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc) + | i <- sortBy (comparing instFam) fam_instances + , let n = getName i + , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap + , not $ isNameHidden expInfo (fi_fam i) + , not $ any (isTypeHidden expInfo) (fi_tys i) + , let opaque = isTypeHidden expInfo (fi_rhs i) + ] + cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] + -- fam_insts but with failing type fams filtered out + cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ] + famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ] + in do + dfs <- getDynFlags + let mkBug = (text "haddock-bug:" <+>) . text + liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + return $ cls_insts ++ cleanFamInsts + Nothing -> return [] + return $ e { expItemInstances = insts } e -> return e where attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = @@ -126,7 +135,7 @@ -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -getAllInfo name = withSession $ \hsc_env -> do +getAllInfo name = withSession $ \hsc_env -> do (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name return r diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where -import Documentation.Haddock.Doc (docAppend) +import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Types import Haddock.Options import Haddock.GhcUtils @@ -45,7 +45,7 @@ import RdrName import TcRnTypes import FastString (concatFS) - +import qualified Outputable as O -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological @@ -157,7 +157,7 @@ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags - (fmap Module.fsToPackageId $ + (fmap Module.fsToPackageKey $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -165,15 +165,13 @@ -- similar to GHC.lookupModule lookupModuleDyn :: - DynFlags -> Maybe PackageId -> ModuleName -> Module + DynFlags -> Maybe PackageKey -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName lookupModuleDyn dflags Nothing mdlName = - flip Module.mkModule mdlName $ - case filter snd $ - Packages.lookupModuleInAllPackages dflags mdlName of - (pkgId,_):_ -> Packages.packageConfigId pkgId - [] -> Module.mainPackageId + case Packages.lookupModuleInAllPackages dflags mdlName of + (m,_):_ -> m + [] -> Module.mkModule Module.mainPackageKey mdlName ------------------------------------------------------------------------------- @@ -196,8 +194,8 @@ parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of - DeprecatedTxt msg -> format "Deprecated: " (concatFS msg) - WarningTxt msg -> format "Warning: " (concatFS msg) + DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg) + WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs @@ -256,19 +254,19 @@ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat - f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name) - f' = M.fromListWith docAppend . concat + f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) + f' = M.fromListWith metaDocAppend . concat mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, Doc Name)] - , [(Name, Map Int (Doc Name))] + -> ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] , [(Name, [Name])] , [(Name, [LHsDecl Name])] ) mappings (ldecl, docStrs) = let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (Doc Name), Map Int (Doc Name)) + -> (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = let doc' = processDocStrings dflags gre strs m' = M.map (processDocStringParas dflags gre) m @@ -333,26 +331,27 @@ dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd) - constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons ] + constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) + | c <- cons, cname <- con_names c ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons - , ConDeclField n _ doc <- flds ] + , L _ (ConDeclField ns _ doc) <- (unLoc flds) + , n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of - SigD (TypeSig _ ty) -> docs (unLoc ty) - SigD (PatSynSig _ arg_tys ty req prov) -> - let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] + SigD (TypeSig _ ty _) -> docs (unLoc ty) + SigD (PatSynSig _ _ req prov ty) -> + let allTys = ty : concat [ unLoc req, unLoc prov ] in F.foldMap (docs . unLoc) allTys ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where - go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) + go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ (L _ doc)) = M.singleton n doc @@ -366,11 +365,7 @@ where decls = docs ++ defs ++ sigs ++ ats docs = mkDecls tcdDocs DocD class_ -#if MIN_VERSION_ghc(7,8,3) defs = mkDecls (bagToList . tcdMeths) ValD class_ -#else - defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_ -#endif sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ @@ -383,7 +378,8 @@ -- | Extract a map of fixity declarations only mkFixMap :: HsGroup Name -> FixMap mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ] + | L _ (FixitySig ns f) <- hs_fixds group_, + L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. @@ -396,11 +392,7 @@ mkDecls hs_docs DocD group_ ++ mkDecls hs_instds InstD group_ ++ mkDecls (typesigs . hs_valds) SigD group_ ++ -#if MIN_VERSION_ghc(7,8,3) mkDecls (valbinds . hs_valds) ValD group_ -#else - mkDecls (map snd . valbinds . hs_valds) ValD group_ -#endif where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs typesigs _ = error "expected ValBindsOut" @@ -503,11 +495,11 @@ Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar x) = declWith x - lookupExport (IEThingAbs t) = declWith t - lookupExport (IEThingAll t) = declWith t - lookupExport (IEThingWith t _) = declWith t - lookupExport (IEModuleContents m) = + lookupExport (IEVar (L _ x)) = declWith x + lookupExport (IEThingAbs (L _ t)) = declWith t + lookupExport (IEThingAll (L _ t)) = declWith t + lookupExport (IEThingWith (L _ t) _) = declWith t + lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr @@ -561,7 +553,7 @@ L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -618,8 +610,15 @@ Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing - Just x -> return (Just (tyThingToLHsDecl x)) - + Just x -> case tyThingToLHsDecl x of + Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing + Right (m, t') -> liftErrMsg (tell $ map bugWarn m) + >> return (Just $ noLoc t') + where + warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> + O.comma O.<+> O.quotes (O.ppr t) O.<+> + O.text "-- Please report this on Haddock issue tracker!" + bugWarn = O.showSDoc dflags . warnLine hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) hiValExportItem dflags name doc splice fixity = do @@ -634,7 +633,8 @@ -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap + -> (DocForDecl Name, [(Name, DocForDecl Name)]) lookupDocs n warnings docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in @@ -689,8 +689,8 @@ "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule packageId expMod - packageId = modulePackageId thisMod + m = mkModule packageKey expMod + packageKey = modulePackageKey thisMod -- Note [1]: @@ -724,7 +724,7 @@ expandSig = foldr f [] where f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : acc) xs names f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs @@ -745,7 +745,7 @@ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name @@ -785,7 +785,8 @@ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , ConDeclField { cd_fld_name = L _ n } <- rec + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns , n == name ] in case matches of @@ -801,10 +802,10 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of - L _ (HsForAllTy expl tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) +extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of + L _ (HsForAllTy expl _ tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) []) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds @@ -817,13 +818,13 @@ extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) + RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] + matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] data_ty - | ResTyGADT ty <- con_res con = ty + | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -21,7 +21,7 @@ import Control.Applicative import Data.IntSet (toList) import Data.List -import Documentation.Haddock.Doc (docConcat) +import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (ExtensionFlag(..), languageExtensions) import FastString import GHC @@ -32,31 +32,26 @@ import Outputable (showPpr) import RdrName -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name) +processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] + -> Maybe (MDoc Name) processDocStrings dflags gre strs = - case docConcat $ map (processDocStringParas dflags gre) strs of - DocEmpty -> Nothing + case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -- We check that we don't have any version info to render instead + -- of just checking if there is no comment: there may not be a + -- comment but we still want to pass through any meta data. + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing x -> Just x - -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocStringParas = process parseParas - +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas dflags gre (HsDocString fs) = + overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocString = process parseString - -process :: (DynFlags -> String -> Doc RdrName) - -> DynFlags - -> GlobalRdrEnv - -> HsDocString - -> Doc Name -process parse dflags gre (HsDocString fs) = - rename dflags gre $ parse dflags (unpackFS fs) - +processDocString dflags gre (HsDocString fs) = + rename dflags gre $ parseString dflags (unpackFS fs) processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString - -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) + -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of @@ -66,7 +61,7 @@ (hmi, doc) = parseModuleHeader dflags str !descr = rename dflags gre <$> hmi_description hmi hmi' = hmi { hmi_description = descr } - doc' = rename dflags gre doc + doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') let flags :: [ExtensionFlag] diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -25,7 +25,7 @@ -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName) +parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName) parseModuleHeader dflags str0 = let getKey :: String -> String -> (Maybe String,String) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -12,7 +13,7 @@ module Haddock.Interface.Rename (renameInterface) where -import Data.Traversable (traverse) +import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types @@ -20,12 +21,13 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name +import NameSet +import Coercion import Control.Applicative import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Data.Traversable (mapM) import Prelude hiding (mapM) @@ -160,10 +162,9 @@ renameLDocHsSyn = return -renameDoc :: Doc Name -> RnM (Doc DocName) +renameDoc :: Traversable t => t Name -> RnM (t DocName) renameDoc = traverse rename - renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc @@ -177,13 +178,14 @@ renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind + renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of - HsForAllTy expl tyvars lcontext ltype -> do + HsForAllTy expl extra tyvars lcontext ltype -> do tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsForAllTy expl tyvars' lcontext' ltype') + return (HsForAllTy expl extra tyvars' lcontext' ltype') HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype @@ -232,6 +234,8 @@ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsWildcardTy -> pure HsWildcardTy + HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c @@ -246,17 +250,16 @@ renameLTyVarBndr (L loc (UserTyVar n)) = do { n' <- rename n ; return (L loc (UserTyVar n')) } -renameLTyVarBndr (L loc (KindedTyVar n kind)) +renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar n' kind')) } + ; return (L loc (KindedTyVar (L lv n') kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') - renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className @@ -294,26 +297,22 @@ renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of - ForeignType lname b -> do - lname' <- renameL lname - return (ForeignType lname' b) - -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl return (FamDecl { tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs }) + return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs }) + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -323,7 +322,7 @@ lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats - at_defs' <- mapM (mapM renameTyFamInstD) at_defs + at_defs' <- mapM renameLTyFamDefltEqn at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag @@ -331,9 +330,9 @@ where renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) + xs' <- mapM rename (map unLoc xs) + ys' <- mapM rename (map unLoc ys) + return (L loc (map noLoc xs', map noLoc ys')) renameLSig (L loc sig) = return . L loc =<< renameSig sig @@ -351,7 +350,7 @@ renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns + = do { eqns' <- mapM renameLTyFamInstEqn eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) @@ -365,19 +364,22 @@ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars +renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do - lname' <- renameL lname + lnames' <- mapM renameL lnames ltyvars' <- renameLTyVarBndrs ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' }) + where - renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields + renameDetails (RecCon (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon (L l fields')) renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a @@ -385,36 +387,34 @@ return (InfixCon a' b') renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t -renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) -renameConDeclFieldField (ConDeclField name t doc) = do - name' <- renameL name +renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) +renameConDeclFieldField (L l (ConDeclField names t doc)) = do + names' <- mapM renameL names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return (ConDeclField name' t' doc') + return $ L l (ConDeclField names' t' doc') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lnames ltype -> do + TypeSig lnames ltype _ -> do lnames' <- mapM renameL lnames ltype' <- renameLType ltype - return (TypeSig lnames' ltype') - PatSynSig lname args ltype lreq lprov -> do + return (TypeSig lnames' ltype' PlaceHolder) + PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname - args' <- case args of - PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs - InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright - ltype' <- renameLType ltype + qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov - return $ PatSynSig lname' args' ltype' lreq' lprov' - FixSig (FixitySig lname fixity) -> do - lname' <- renameL lname - return $ FixSig (FixitySig lname' fixity) - MinimalSig s -> MinimalSig <$> traverse renameL s + lty' <- renameLType lty + return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty' + FixSig (FixitySig lnames fixity) -> do + lnames' <- mapM renameL lnames + return $ FixSig (FixitySig lnames' fixity) + MinimalSig src s -> MinimalSig src <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -442,34 +442,50 @@ return (DataFamInstD { dfid_inst = d' }) renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) -renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do +renameClsInstD (ClsInstDecl { cid_overlap_mode = omode + , cid_poly_ty =ltype, cid_tyfam_insts = lATs + , cid_datafam_insts = lADTs }) = do ltype' <- renameLType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + return (ClsInstDecl { cid_overlap_mode = omode + , cid_poly_ty = ltype', cid_binds = emptyBag + , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn' <- renameLThing renameTyFamInstEqn eqn + = do { eqn' <- renameLTyFamInstEqn eqn ; return (TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames }) } -renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName) -renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs }) +renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) +renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; rhs' <- renameLType rhs - ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' } - , tfie_rhs = rhs' }) } + ; return (L loc (TyFamEqn { tfe_tycon = tc' + , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder + , tfe_rhs = rhs' })) } +renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) +renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) + = do { tc' <- renameL tc + ; tvs' <- renameLTyVarBndrs tvs + ; rhs' <- renameLType rhs + ; return (L loc (TyFamEqn { tfe_tycon = tc' + , tfe_pats = tvs' + , tfe_rhs = rhs' })) } + renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' } + ; return (DataFamInstDecl { dfid_tycon = tc' + , dfid_pats + = HsWB pats' PlaceHolder PlaceHolder PlaceHolder , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) @@ -482,10 +498,10 @@ decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc) -> do + instances' <- forM instances $ \(L l inst, idoc) -> do inst' <- renameInstHead inst idoc' <- mapM renameDoc idoc - return (inst', idoc') + return (L l inst', idoc') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) @@ -504,3 +520,12 @@ n' <- rename n doc' <- renameDocForDecl doc return (n', doc') + +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName [Name] = PlaceHolder + +type instance PostTc DocName Kind = PlaceHolder +type instance PostTc DocName Type = PlaceHolder +type instance PostTc DocName Coercion = PlaceHolder diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageId, + InterfaceFile(..), ifPackageKey, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -52,11 +52,11 @@ } -ifPackageId :: InterfaceFile -> PackageId -ifPackageId if_ = +ifPackageKey :: InterfaceFile -> PackageKey +ifPackageKey if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageId $ instMod iface + iface:_ -> modulePackageKey $ instMod iface binaryInterfaceMagic :: Word32 @@ -76,8 +76,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 708 -binaryInterfaceVersion = 25 +#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711) +binaryInterfaceVersion = 27 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -310,7 +310,7 @@ return (namecache', arr) -type OnDiskName = (PackageId, ModuleName, OccName) +type OnDiskName = (PackageKey, ModuleName, OccName) fromOnDiskName @@ -340,7 +340,7 @@ serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (modulePackageId modu, moduleName modu, nameOccName name) + put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- @@ -454,6 +454,19 @@ l <- get bh t <- get bh return (Header l t) + +instance Binary Meta where + put_ bh Meta { _version = v } = put_ bh v + get bh = (\v -> Meta { _version = v }) <$> get bh + +instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where + put_ bh MetaDoc { _meta = m, _doc = d } = do + put_ bh m + put_ bh d + get bh = do + m <- get bh + d <- get bh + return $ MetaDoc { _meta = m, _doc = d } {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary mod, Binary id) => Binary (DocH mod id) where diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -12,26 +12,29 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.Types ( Doc ) +import Haddock.Types ( MDoc ) import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageId, - packageIdString ) +import Module ( Module, moduleNameString, moduleName, modulePackageKey ) +import DynFlags ( DynFlags ) +import Packages ( lookupPackage ) +import PackageConfig ( sourcePackageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] -mkModuleTree showPkgs mods = +mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] +mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) + modPkg mod_ | showPkgs = fmap sourcePackageIdString + (lookupPackage dflags (modulePackageKey mod_)) | otherwise = Nothing fn (mod_,pkg,short) = addToTrees mod_ pkg short -addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] addToTrees [] _ _ ts = ts addToTrees ss pkg short [] = mkSubTree ss pkg short addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) @@ -43,7 +46,7 @@ this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] +mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] mkSubTree [] _ _ = [] mkSubTree [s] pkg short = [Node s True pkg short []] mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -28,15 +28,21 @@ qualification, verbosity, ghcFlags, - readIfaceArgs + readIfaceArgs, + optPackageName, + optPackageVersion ) where -import Distribution.Verbosity -import Haddock.Utils -import Haddock.Types -import System.Console.GetOpt import qualified Data.Char as Char +import Data.Version +import Distribution.Verbosity +import FastString +import Haddock.Types +import Haddock.Utils +import Packages +import System.Console.GetOpt +import qualified Text.ParserCombinators.ReadP as RP data Flag @@ -82,8 +88,10 @@ | Flag_NoTmpCompDir | Flag_Qualification String | Flag_PrettyHtml - | Flag_PrintMissingDocs - deriving (Eq) + | Flag_NoPrintMissingDocs + | Flag_PackageName String + | Flag_PackageVersion String + deriving (Eq, Show) options :: Bool -> [OptDescr Flag] @@ -107,7 +115,7 @@ Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) - "output for Hoogle", + "output for Hoogle; you may want --package-name and --package-version too", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) @@ -170,8 +178,12 @@ "do not re-direct compilation output to a temporary directory", Option [] ["pretty-html"] (NoArg Flag_PrettyHtml) "generate html with newlines and indenting (for use with --html)", - Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs) - "print information about any undocumented entities" + Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) + "don't print information about any undocumented entities", + Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") + "name of the package being documented", + Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") + "version of the package being documented in usual x.y.z.w format" ] @@ -191,6 +203,15 @@ (_, _, errors) -> do usage <- getUsage throwE (concat errors ++ usage) + +optPackageVersion :: [Flag] -> Maybe Data.Version.Version +optPackageVersion flags = + let ver = optLast [ v | Flag_PackageVersion v <- flags ] + in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion + +optPackageName :: [Flag] -> Maybe PackageName +optPackageName flags = + optLast [ PackageName $ mkFastString n | Flag_PackageName n <- flags ] optTitle :: [Flag] -> Maybe String diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -28,8 +28,8 @@ import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -parseParas :: DynFlags -> String -> DocH mod RdrName -parseParas d = P.overIdentifier (parseIdent d) . P.parseParas +parseParas :: DynFlags -> String -> MetaDoc mod RdrName +parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas parseString :: DynFlags -> String -> DocH mod RdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -34,7 +34,6 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable -import Control.Applicative (Applicative(..)) import Control.Monad (ap) ----------------------------------------------------------------------------- @@ -44,13 +43,13 @@ type IfaceMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface -- TODO: rename -type DocMap a = Map Name (Doc a) -type ArgMap a = Map Name (Map Int (Doc a)) +type DocMap a = Map Name (MDoc a) +type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageId FilePath +type SrcMap = Map PackageKey FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -128,7 +127,7 @@ , ifaceWarningMap :: !WarningMap } -type WarningMap = DocMap Name +type WarningMap = Map Name (Doc Name) -- | A subset of the fields of 'Interface' that we store in the interface @@ -233,20 +232,20 @@ } -- | Some documentation. - | ExportDoc !(Doc name) + | ExportDoc !(MDoc name) -- | A cross-reference to another module. | ExportModule !Module data Documentation name = Documentation - { documentationDoc :: Maybe (Doc name) + { documentationDoc :: Maybe (MDoc name) , documentationWarning :: !(Maybe (Doc name)) } deriving Functor -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. -type FnArgsDoc name = Map Int (Doc name) +type FnArgsDoc name = Map Int (MDoc name) type DocForDecl name = (Documentation name, FnArgsDoc name) @@ -300,8 +299,8 @@ ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a --- | An instance head that may have documentation. -type DocInstance name = (InstHead name, Maybe (Doc name)) +-- | An instance head that may have documentation and a source location. +type DocInstance name = (Located (InstHead name), Maybe (MDoc name)) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type @@ -315,6 +314,7 @@ type LDoc id = Located (Doc id) type Doc id = DocH (ModuleName, OccName) id +type MDoc id = MetaDoc (ModuleName, OccName) id instance (NFData a, NFData mod) => NFData (DocH mod a) where @@ -342,9 +342,9 @@ DocHeader a -> a `deepseq` () -instance NFData Name -instance NFData OccName -instance NFData ModuleName +instance NFData Name where rnf x = seq x () +instance NFData OccName where rnf x = seq x () +instance NFData ModuleName where rnf x = seq x () instance NFData id => NFData (Header id) where rnf (Header a b) = a `deepseq` b `deepseq` () diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -39,6 +39,7 @@ -- * Doc markup markup, idMarkup, + mkMeta, -- * List utilities replace, @@ -56,6 +57,7 @@ ) where +import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types import Haddock.GhcUtils @@ -110,14 +112,16 @@ -- | Extract a module's short description. -toDescription :: Interface -> Maybe (Doc Name) -toDescription = hmi_description . ifaceInfo +toDescription :: Interface -> Maybe (MDoc Name) +toDescription = fmap mkMeta . hmi_description . ifaceInfo -- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) -toInstalledDescription = hmi_description . instInfo +toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) +toInstalledDescription = fmap mkMeta . hmi_description . instInfo +mkMeta :: Doc a -> MDoc a +mkMeta x = emptyMetaDoc { _doc = x } -------------------------------------------------------------------------------- -- * Making abstract declarations @@ -146,24 +150,23 @@ restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | unLoc (con_name d) `elem` names = + keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = case con_details d of PrefixCon _ -> Just d RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (ConDeclField n _ _) = unLoc n `elem` names + field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing - restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) @@ -300,11 +303,7 @@ bye s = putStr s >> exitSuccess -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - - -dieMsg :: String -> IO a +dieMsg :: String -> IO () dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)