haddock 2.9.4 → 2.10.0
raw patch · 30 files changed
+921/−1018 lines, 30 filesdep −regex-compatdep ~basedep ~ghc
Dependencies removed: regex-compat
Dependency ranges changed: base, ghc
Files
- CHANGES +16/−0
- dist/build/haddock/haddock-tmp/Haddock/Lex.hs +5/−9
- dist/build/haddock/haddock-tmp/Haddock/Parse.hs +6/−4
- doc/haddock.xml +1/−1
- haddock.cabal +14/−10
- haddock.spec +1/−1
- html/Classic.theme/xhaddock.css +6/−0
- src/Documentation/Haddock.hs +0/−2
- src/Haddock/Backends/Hoogle.hs +21/−20
- src/Haddock/Backends/LaTeX.hs +54/−64
- src/Haddock/Backends/Xhtml.hs +23/−22
- src/Haddock/Backends/Xhtml/Decl.hs +32/−33
- src/Haddock/Backends/Xhtml/DocMarkup.hs +27/−40
- src/Haddock/Backends/Xhtml/Names.hs +16/−4
- src/Haddock/Convert.hs +48/−51
- src/Haddock/GhcUtils.hs +15/−17
- src/Haddock/Interface/AttachInstances.hs +3/−12
- src/Haddock/Interface/Create.hs +252/−356
- src/Haddock/Interface/ExtractFnArgDocs.hs +0/−49
- src/Haddock/Interface/LexParseRn.hs +82/−19
- src/Haddock/Interface/ParseModuleHeader.hs +2/−1
- src/Haddock/Interface/Rename.hs +44/−57
- src/Haddock/Interface/Rn.hs +0/−83
- src/Haddock/InterfaceFile.hs +56/−33
- src/Haddock/Lex.x +5/−9
- src/Haddock/Options.hs +6/−0
- src/Haddock/Types.hs +48/−34
- src/Haddock/Utils.hs +64/−39
- src/Main.hs +36/−25
- tests/html-tests/runtests.hs +38/−23
CHANGES view
@@ -1,3 +1,19 @@+Changes in version 2.10.0++ * Require GHC >= 7.4++ * Safe Haskell indications on module pages++ * Type declarations on identifiers no longer necessary++ * Add flag --interface-version++ * Warn when comment refers to in-scope identifier without documentation++ * Bug fix: links to out-of-scope things (#78)++ * Bug fix: module references to other packages work again+ Changes in version 2.9.4 * Require GHC >= 7.2
dist/build/haddock/haddock-tmp/Haddock/Lex.hs view
@@ -71,7 +71,7 @@ | TokDefStart | TokDefEnd | TokSpecial Char- | TokIdent [RdrName]+ | TokIdent RdrName | TokString String | TokURL String | TokPic String@@ -159,7 +159,7 @@ ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags loc id of+ case parseIdent dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str)@@ -170,17 +170,13 @@ AlexPn _ line col -> mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName]-strToHsQNames dflags loc str0 = -#if MIN_VERSION_ghc(7,1,0)+parseIdent :: DynFlags -> RealSrcLoc -> String -> Maybe RdrName+parseIdent dflags loc str0 = let buffer = stringToStringBuffer str0-#else- let buffer = unsafePerformIO (stringToStringBuffer str0)-#endif pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of - POk _ name -> Just [unLoc name] + POk _ name -> Just (unLoc name) _ -> Nothing
dist/build/haddock/haddock-tmp/Haddock/Parse.hs view
@@ -21,7 +21,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.6+-- parser produced by Happy Version 1.18.9 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -511,7 +511,8 @@ _ -> happyError' (tk:tks) } -happyError_ tk tks = happyError' (tk:tks)+happyError_ 19# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks) happyThen :: () => Maybe a -> (a -> Maybe b) -> Maybe b happyThen = (>>=)@@ -748,9 +749,10 @@ -- Error recovery (0# is the error token) -- parse error if we are in recovery and we fail again-happyFail 0# tk old_st _ stk =+happyFail 0# tk old_st _ stk@(x `HappyStk` _) =+ let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "failing" $ - happyError_ tk+ happyError_ i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it
doc/haddock.xml view
@@ -21,7 +21,7 @@ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.9.4, a Haskell+ <para>This document describes Haddock version 2.10.0, a Haskell documentation tool.</para> </abstract> </bookinfo>
haddock.cabal view
@@ -1,5 +1,5 @@ name: haddock-version: 2.9.4+version: 2.10.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -78,8 +78,12 @@ executable haddock default-language: Haskell2010+ -- In a GHC tree - in particular, in a source tarball - we don't+ -- require alex or happy+ if !flag(in-ghc-tree)+ build-tools: alex >= 2.3, happy >= 1.18 build-depends:- base >= 4.3 && < 4.5,+ base >= 4.3 && < 4.6, filepath, directory, pretty,@@ -87,7 +91,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10,- ghc >= 7.2 && < 7.4+ ghc >= 7.4 && < 7.6 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -108,9 +112,7 @@ Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create- Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances- Haddock.Interface.Rn Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Lex@@ -138,8 +140,12 @@ library default-language: Haskell2010+ -- In a GHC tree - in particular, in a source tarball - we don't+ -- require alex or happy+ if !flag(in-ghc-tree)+ build-tools: alex >= 2.3, happy >= 1.18 build-depends:- base >= 4.3 && < 4.5,+ base >= 4.3 && < 4.6, filepath, directory, pretty,@@ -147,7 +153,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10,- ghc >= 7.2 && < 7.4+ ghc >= 7.4 && < 7.6 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -171,9 +177,7 @@ Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create- Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances- Haddock.Interface.Rn Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Lex@@ -208,7 +212,7 @@ default-language: Haskell2010 main-is: runtests.hs hs-source-dirs: tests/html-tests- build-depends: base, directory, process, filepath, Cabal, regex-compat+ build-depends: base, directory, process, filepath, Cabal source-repository head type: git
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.9.4+%define version 2.10.0 %define release 1 Name: %{name}
html/Classic.theme/xhaddock.css view
@@ -156,6 +156,12 @@ } #module-header {+ overflow: hidden; /* makes sure info float is properly contained */+ display: inline-block; /* triggers hasLayout in IE*/+}++#module-header {+ display: block; /* back to block */ background-color: #0077dd; padding: 5px; }
src/Documentation/Haddock.hs view
@@ -21,8 +21,6 @@ -- * Export items & declarations ExportItem(..),- Decl,- DeclInfo, DocForDecl, FnArgsDoc,
src/Haddock/Backends/Hoogle.hs view
@@ -114,8 +114,8 @@ f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d f (TyClD d@TySynonym{}) = ppSynonym d- f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ- f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ+ f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ+ f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ f (SigD sig) = ppSig sig f _ = [] ppExport _ = []@@ -143,10 +143,10 @@ addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) addContext _ = error "expected TypeSig" - f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d+ f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d f t = HsForAllTy Implicit [] (reL [context]) (reL t) - context = reL $ HsClassP (unL $ tcdLName x)+ context = nlHsTyConApp (unL $ tcdLName x) (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x)) @@ -228,22 +228,23 @@ markupTag :: Outputable o => DocMarkup o [Tag] markupTag = Markup {- markupParagraph = box TagP,- markupEmpty = str "",- markupString = str,- markupAppend = (++),- markupIdentifier = box (TagInline "a") . str . out . head,- markupModule = box (TagInline "a") . str,- markupEmphasis = box (TagInline "i"),- markupMonospaced = box (TagInline "tt"),- markupPic = const $ str " ",- markupUnorderedList = box (TagL 'u'),- markupOrderedList = box (TagL 'o'),- markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),- markupCodeBlock = box TagPre,- markupURL = box (TagInline "a") . str,- markupAName = const $ str "",- markupExample = box TagPre . str . unlines . map exampleToString+ markupParagraph = box TagP,+ markupEmpty = str "",+ markupString = str,+ markupAppend = (++),+ markupIdentifier = box (TagInline "a") . str . out,+ markupIdentifierUnchecked = box (TagInline "a") . str . out . snd,+ markupModule = box (TagInline "a") . str,+ markupEmphasis = box (TagInline "i"),+ markupMonospaced = box (TagInline "tt"),+ markupPic = const $ str " ",+ markupUnorderedList = box (TagL 'u'),+ markupOrderedList = box (TagL 'o'),+ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),+ markupCodeBlock = box TagPre,+ markupURL = box (TagInline "a") . str,+ markupAName = const $ str "",+ markupExample = box TagPre . str . unlines . map exampleToString }
src/Haddock/Backends/LaTeX.hs view
@@ -17,15 +17,14 @@ import Haddock.Types import Haddock.Utils import Haddock.GhcUtils-import Pretty hiding (Doc)+import Pretty hiding (Doc, quote) import qualified Pretty import GHC import OccName-import Name ( isTyConName, nameOccName )-import RdrName ( rdrNameOcc, isRdrTc )-import BasicTypes ( IPName(..), Boxity(..) )-import Outputable ( Outputable, ppr, showSDoc )+import Name ( nameOccName )+import RdrName ( rdrNameOcc )+import BasicTypes ( ipNameName ) import FastString ( unpackFS, unpackLitString ) import qualified Data.Map as Map@@ -450,7 +449,7 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode =@@ -473,7 +472,7 @@ -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX ppClassDecl instances loc mbDoc subdocs- (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode+ (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit where@@ -486,8 +485,8 @@ body = catMaybes [fmap docToLaTeX mbDoc, body_] body_- | null lsigs, null ats = Nothing- | null ats = Just methodTable+ | null lsigs, null ats, null at_defs = Nothing+ | null ats, null at_defs = Just methodTable --- | otherwise = atTable $$ methodTable | otherwise = error "LaTeX.ppClassDecl" @@ -771,7 +770,7 @@ ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode -ppContextNoLocs :: [HsPred DocName] -> Bool -> LaTeX+ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX ppContextNoLocs [] _ = empty ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode @@ -780,17 +779,10 @@ ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode -pp_hs_context :: [HsPred DocName] -> Bool -> LaTeX+pp_hs_context :: [HsType DocName] -> Bool -> LaTeX pp_hs_context [] _ = empty-pp_hs_context [p] unicode = ppPred unicode p-pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)---ppPred :: Bool -> HsPred DocName -> LaTeX-ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode-ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <> text "~" <> ppLType unicode t2-ppPred unicode (HsIParam (IPName n) t)- = char '?' <> ppDocName n <> dcolon unicode <> ppLType unicode t+pp_hs_context [p] unicode = ppType unicode p+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) -------------------------------------------------------------------------------@@ -798,18 +790,14 @@ ------------------------------------------------------------------------------- -ppKind :: Outputable a => a -> LaTeX-ppKind k = text (showSDoc (ppr k))-- ppBang :: HsBang -> LaTeX ppBang HsNoBang = empty ppBang _ = char '!' -- Unpacked args is an implementation detail, -tupleParens :: Boxity -> [LaTeX] -> LaTeX-tupleParens Boxed = parenList-tupleParens Unboxed = ubxParenList+tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX+tupleParens HsUnboxedTuple = ubxParenList+tupleParens _ = parenList -------------------------------------------------------------------------------@@ -847,7 +835,13 @@ ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode +ppLKind :: Bool -> LHsKind DocName -> LaTeX+ppLKind unicode y = ppKind unicode (unLoc y) +ppKind :: Bool -> HsKind DocName -> LaTeX+ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode++ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell @@ -875,20 +869,27 @@ ppr_mono_ty _ (HsTyVar name) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)+ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys+ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode+ = maybeParen ctxt_prec pREC_OP $+ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode+ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where@@ -996,56 +997,45 @@ ------------------------------------------------------------------------------- -parLatexMarkup :: (a -> LaTeX) -> (a -> Bool)- -> DocMarkup a (StringContext -> LaTeX)-parLatexMarkup ppId isTyCon = Markup {- markupParagraph = \p v -> p v <> text "\\par" $$ text "",- markupEmpty = \_ -> empty,- markupString = \s v -> text (fixString v s),- markupAppend = \l r v -> l v <> r v,- markupIdentifier = markupId,- markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),- markupEmphasis = \p v -> emph (p v),- markupMonospaced = \p _ -> tt (p Mono),- markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",- markupPic = \path _ -> parens (text "image: " <> text path),- markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",- markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),- markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",- markupURL = \u _ -> text "\\url" <> braces (text u),- markupAName = \_ _ -> empty,- markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e+parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)+parLatexMarkup ppId = Markup {+ markupParagraph = \p v -> p v <> text "\\par" $$ text "",+ markupEmpty = \_ -> empty,+ markupString = \s v -> text (fixString v s),+ markupAppend = \l r v -> l v <> r v,+ markupIdentifier = markupId ppId,+ markupIdentifierUnchecked = markupId (ppVerbOccName . snd),+ markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),+ markupEmphasis = \p v -> emph (p v),+ markupMonospaced = \p _ -> tt (p Mono),+ markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",+ markupPic = \path _ -> parens (text "image: " <> text path),+ markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",+ markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),+ markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",+ markupURL = \u _ -> text "\\url" <> braces (text u),+ markupAName = \_ _ -> empty,+ markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e } where fixString Plain s = latexFilter s fixString Verb s = s fixString Mono s = latexMonoFilter s - markupId id v =+ markupId ppId_ id v = case v of Verb -> theid Mono -> theid Plain -> text "\\haddockid" <> braces theid- where theid = ppId (choose id)-- -- If an id can refer to multiple things, we give precedence to type- -- constructors. This should ideally be done during renaming from RdrName- -- to Name, but since we will move this process from GHC into Haddock in- -- the future, we fix it here in the meantime.- -- TODO: mention this rule in the documentation.- choose [] = error "empty identifier list in HsDoc"- choose [x] = x- choose (x:y:_)- | isTyCon x = x- | otherwise = y+ where theid = ppId_ id latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)-latexMarkup = parLatexMarkup ppVerbDocName (isTyConName . getName)+latexMarkup = parLatexMarkup ppVerbDocName rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)-rdrLatexMarkup = parLatexMarkup ppVerbRdrName isRdrTc+rdrLatexMarkup = parLatexMarkup ppVerbRdrName docToLaTeX :: Doc DocName -> LaTeX
src/Haddock/Backends/Xhtml.hs view
@@ -83,8 +83,7 @@ themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents- prologue- debug+ prologue debug qual when (isNothing maybe_index_url) $ ppHtmlIndex odir doctitle maybe_package@@ -200,7 +199,8 @@ entries = mapMaybe doOneEntry [ ("Portability",hmi_portability), ("Stability",hmi_stability),- ("Maintainer",hmi_maintainer)+ ("Maintainer",hmi_maintainer),+ ("Safe Haskell",hmi_safety) ] in case entries of@@ -223,10 +223,11 @@ -> WikiURLs -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) -> Bool+ -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents odir doctitle _maybe_package themes maybe_index_url- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug = do+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do let tree = mkModuleTree showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html =@@ -234,8 +235,8 @@ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [- ppPrologue doctitle prologue,- ppModuleTree tree+ ppPrologue qual doctitle prologue,+ ppModuleTree qual tree ] createDirectoryIfMissing True odir writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)@@ -244,27 +245,27 @@ ppHtmlContentsFrame odir doctitle themes ifaces debug -ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html-ppPrologue _ Nothing = noHtml-ppPrologue title (Just doc) =- divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml doc))+ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html+ppPrologue _ _ Nothing = noHtml+ppPrologue qual title (Just doc) =+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) -ppModuleTree :: [ModuleTree] -> Html-ppModuleTree ts =- divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts)+ppModuleTree :: Qualification -> [ModuleTree] -> Html+ppModuleTree qual ts =+ divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) -mkNodeList :: [String] -> String -> [ModuleTree] -> Html-mkNodeList ss p ts = case ts of+mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html+mkNodeList qual ss p ts = case ts of [] -> noHtml- _ -> unordList (zipWith (mkNode ss) ps ts)+ _ -> unordList (zipWith (mkNode qual ss) ps ts) where ps = [ p ++ '.' : show i | i <- [(1::Int)..]] -mkNode :: [String] -> String -> ModuleTree -> Html-mkNode ss p (Node s leaf pkg short ts) =+mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html+mkNode qual ss p (Node s leaf pkg short ts) = htmlModule +++ shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of@@ -287,10 +288,10 @@ mdl = intercalate "." (reverse (s:ss)) - shortDescr = maybe noHtml origDocToHtml short+ shortDescr = maybe noHtml (origDocToHtml qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg - subtree = mkNodeList (s:ss) p ts ! collapseSection p True ""+ subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" -- | Turn a module tree into a flat list of full module names. E.g.,@@ -557,10 +558,10 @@ processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName -> [Html]-processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) =+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) = ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of- (TyFamily{}) -> [ppTyFamHeader True False d unicode]+ (TyFamily{}) -> [ppTyFamHeader True False d unicode qual] (TyData{tcdTyPats = ps}) | Nothing <- ps -> [keyword "data" <+> b] | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b]
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -32,10 +32,9 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) -import BasicTypes ( IPName(..), Boxity(..) ) import GHC import Name-import Outputable ( ppr, showSDoc, Outputable )+import BasicTypes ( ipNameName ) -- TODO: use DeclInfo DocName or something@@ -114,7 +113,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Qualification -> Html-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode qual = ppFunSig summary links loc doc [name] typ unicode qual ppFor _ _ _ _ _ _ _ = error "ppFor" @@ -150,8 +149,8 @@ -------------------------------------------------------------------------------- -ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html-ppTyFamHeader summary associated decl unicode =+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html+ppTyFamHeader summary associated decl unicode qual = (case tcdFlavour decl of TypeFamily@@ -165,7 +164,7 @@ ppTyClBinderWithVars summary decl <+> case tcdKind decl of- Just kind -> dcolon unicode <+> ppKind kind+ Just kind -> dcolon unicode <+> ppLKind unicode qual kind Nothing -> noHtml @@ -173,13 +172,13 @@ TyClDecl DocName -> Bool -> Qualification -> Html ppTyFam summary associated links loc mbDoc decl unicode qual - | summary = ppTyFamHeader True associated decl unicode+ | summary = ppTyFamHeader True associated decl unicode qual | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit where docname = tcdName decl - header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode)+ header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual) instancesBit = ppInstances instances docname unicode qual @@ -301,7 +300,7 @@ ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual -ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html+ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html ppContextNoLocs [] _ _ = noHtml ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual <+> darrow unicode@@ -311,18 +310,10 @@ ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html+pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html pp_hs_context [] _ _ = noHtml-pp_hs_context [p] unicode qual = ppPred unicode qual p-pp_hs_context cxt unicode qual = parenList (map (ppPred unicode qual) cxt)---ppPred :: Bool -> Qualification -> HsPred DocName -> Html-ppPred unicode qual (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode qual-ppPred unicode qual (HsEqualP t1 t2) = ppLType unicode qual t1 <+> toHtml "~"- <+> ppLType unicode qual t2-ppPred unicode qual (HsIParam (IPName n) t)- = toHtml "?" +++ ppDocName qual n <+> dcolon unicode <+> ppLType unicode qual t+pp_hs_context [p] unicode qual = ppType unicode qual p+pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) -------------------------------------------------------------------------------@@ -330,7 +321,7 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual =@@ -352,7 +343,7 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr@@ -381,7 +372,7 @@ -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html ppClassDecl summary links instances loc mbDoc subdocs- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual | otherwise = classheader +++ maybeDocSection qual mbDoc +++ atBit +++ methodBit +++ instancesBit@@ -643,19 +634,15 @@ -------------------------------------------------------------------------------- -ppKind :: Outputable a => a -> Html-ppKind k = toHtml $ showSDoc (ppr k)-- ppBang :: HsBang -> Html ppBang HsNoBang = noHtml ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, -- so we just show the strictness annotation -tupleParens :: Boxity -> [Html] -> Html-tupleParens Boxed = parenList-tupleParens Unboxed = ubxParenList+tupleParens :: HsTupleSort -> [Html] -> Html+tupleParens HsUnboxedTuple = ubxParenList+tupleParens _ = parenList --------------------------------------------------------------------------------@@ -692,7 +679,12 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppLKind :: Bool -> Qualification-> LHsKind DocName -> Html+ppLKind unicode qual y = ppKind unicode qual (unLoc y) +ppKind :: Bool -> Qualification-> HsKind DocName -> Html+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual+ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell @@ -721,10 +713,10 @@ ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q =- parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)-ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p)+ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" #if __GLASGOW_HASKELL__ == 612 ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"@@ -733,12 +725,19 @@ #endif ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys+ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual+ = maybeParen ctxt_prec pREC_OP $+ ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual+ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -21,49 +21,36 @@ import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils-import Haddock.GhcUtils import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) import GHC-import Name-import RdrName -parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html-parHtmlMarkup ppId isTyCon = Markup {- markupEmpty = noHtml,- markupString = toHtml,- markupParagraph = paragraph,- markupAppend = (+++),- markupIdentifier = thecode . ppId . choose,- markupModule = \m -> let (mdl,ref) = break (=='#') m- in ppModuleRef (mkModuleNoPackage mdl) ref,- markupEmphasis = emphasize,- markupMonospaced = thecode,- markupUnorderedList = unordList,- markupOrderedList = ordList,- markupDefList = defList,- markupCodeBlock = pre,- markupURL = \url -> anchor ! [href url] << url,- markupAName = \aname -> namedAnchor aname << "",- markupPic = \path -> image ! [src path],- markupExample = examplesToHtml+parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html+parHtmlMarkup qual ppId = Markup {+ markupEmpty = noHtml,+ markupString = toHtml,+ markupParagraph = paragraph,+ markupAppend = (+++),+ markupIdentifier = thecode . ppId,+ markupIdentifierUnchecked = thecode . ppUncheckedLink qual,+ markupModule = \m -> let (mdl,ref) = break (=='#') m+ in ppModuleRef (mkModuleName mdl) ref,+ markupEmphasis = emphasize,+ markupMonospaced = thecode,+ markupUnorderedList = unordList,+ markupOrderedList = ordList,+ markupDefList = defList,+ markupCodeBlock = pre,+ markupURL = \url -> anchor ! [href url] << url,+ markupAName = \aname -> namedAnchor aname << "",+ markupPic = \path -> image ! [src path],+ markupExample = examplesToHtml } where- -- If an id can refer to multiple things, we give precedence to type- -- constructors. This should ideally be done during renaming from RdrName- -- to Name, but since we will move this process from GHC into Haddock in- -- the future, we fix it here in the meantime.- -- TODO: mention this rule in the documentation.- choose [] = error "empty identifier list in HsDoc"- choose [x] = x- choose (x:y:_)- | isTyCon x = x- | otherwise = y- examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] exampleToHtml (Example expression result) = htmlExample@@ -77,17 +64,17 @@ -- ugly extra whitespace with some browsers). FIXME: Does this still apply? docToHtml :: Qualification -> Doc DocName -> Html docToHtml qual = markup fmt . cleanup- where fmt = parHtmlMarkup (ppDocName qual) (isTyConName . getName)+ where fmt = parHtmlMarkup qual (ppDocName qual) -origDocToHtml :: Doc Name -> Html-origDocToHtml = markup fmt . cleanup- where fmt = parHtmlMarkup ppName isTyConName+origDocToHtml :: Qualification -> Doc Name -> Html+origDocToHtml qual = markup fmt . cleanup+ where fmt = parHtmlMarkup qual ppName -rdrDocToHtml :: Doc RdrName -> Html-rdrDocToHtml = markup fmt . cleanup- where fmt = parHtmlMarkup ppRdrName isRdrTc+rdrDocToHtml :: Qualification -> Doc RdrName -> Html+rdrDocToHtml qual = markup fmt . cleanup+ where fmt = parHtmlMarkup qual ppRdrName docElement :: (Html -> Html) -> Html -> Html
src/Haddock/Backends/Xhtml/Names.hs view
@@ -11,7 +11,7 @@ -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Names (- ppName, ppDocName, ppLDocName, ppRdrName,+ ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinder', ppModule, ppModuleRef, linkId@@ -39,6 +39,10 @@ ppRdrName = ppOccName . rdrNameOcc +ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName++ ppLDocName :: Qualification -> Located DocName -> Html ppLDocName qual (L _ d) = ppDocName qual d @@ -110,14 +114,22 @@ Just name -> moduleNameUrl mdl name +linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html+linkIdOcc' mdl mbName = anchor ! [href url]+ where+ url = case mbName of+ Nothing -> moduleHtmlFile' mdl+ Just name -> moduleNameUrl' mdl name++ ppModule :: Module -> Html ppModule mdl = anchor ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: Module -> String -> Html-ppModuleRef mdl ref = anchor ! [href (moduleUrl mdl ++ ref)]- << toHtml (moduleString mdl)+ppModuleRef :: ModuleName -> String -> Html+ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]+ << toHtml (moduleNameString mdl) -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used.
src/Haddock/Convert.hs view
@@ -20,14 +20,15 @@ import HsSyn import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy ) import TypeRep-import Coercion ( splitKindFunTys, synTyConResKind )+import Kind ( splitKindFunTys, synTyConResKind ) import Name import Var import Class import TyCon import DataCon+import BasicTypes ( TupleSort(..) ) import TysPrim ( alphaTyVars )-import TysWiredIn ( listTyConName )+import TysWiredIn ( listTyConName, eqTyCon ) import Bag ( emptyBag ) import SrcLoc ( Located, noLoc, unLoc ) @@ -47,7 +48,24 @@ -- 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 -> TyClD (synifyTyCon tc)+ ATyCon tc+ | Just cl <- tyConClass_maybe tc -- classes are just a little tedious+ -> TyClD $ ClassDecl+ (synifyCtx (classSCTheta cl))+ (synifyName cl)+ (synifyTyVars (classTyVars cl))+ (map (\ (l,r) -> noLoc+ (map getName l, map getName r) ) $+ snd $ classTvsFds cl)+ (map (noLoc . synifyIdSig DeleteTopLevelQuantification)+ (classMethods cl))+ emptyBag --ignore default method definitions, they don't affect signature+ -- class associated-types are a subset of TyCon:+ [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]+ [] --ignore associated type defaults+ [] --we don't have any docs at this point+ | otherwise+ -> TyClD (synifyTyCon tc) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.)@@ -56,26 +74,10 @@ -- a data-constructor alone just gets rendered as a function: ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc)))- -- classes are just a little tedious- AClass cl ->- TyClD $ ClassDecl- (synifyCtx (classSCTheta cl))- (synifyName cl)- (synifyTyVars (classTyVars cl))- (map (\ (l,r) -> noLoc- (map getName l, map getName r) ) $- snd $ classTvsFds cl)- (map (noLoc . synifyIdSig DeleteTopLevelQuantification)- (classMethods cl))- emptyBag --ignore default method definitions, they don't affect signature- (map synifyClassAT (classATs cl))- [] --we don't have any docs at this point ---- class associated-types are a subset of TyCon--- (mainly only type/data-families)-synifyClassAT :: TyCon -> LTyClDecl Name-synifyClassAT = noLoc . synifyTyCon+synifyATDefault :: TyCon -> LTyClDecl Name+synifyATDefault tc = noLoc (synifyAxiom ax)+ where Just ax = tyConFamilyCoercion_maybe tc synifyAxiom :: CoAxiom -> TyClDecl Name synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })@@ -100,14 +102,14 @@ -- tyConTyVars doesn't work on fun/prim, but we can make them up: (zipWith (\fakeTyVar realKind -> noLoc $- KindedTyVar (getName fakeTyVar) realKind)+ KindedTyVar (getName fakeTyVar) (synifyKind realKind) placeHolderKind) alphaTyVars --a, b, c... which are unfortunately all kind * (fst . splitKindFunTys $ tyConKind tc) ) -- assume primitive types aren't members of data/newtype families: Nothing -- we have their kind accurately:- (Just (tyConKind tc))+ (Just (synifyKind (tyConKind tc))) -- no algebraic constructors: [] -- "deriving" needn't be specified:@@ -116,13 +118,14 @@ case synTyConRhs tc of SynFamilyTyCon -> TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))- (Just (synTyConResKind tc))+ (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind _ -> error "synifyTyCon: impossible open type synonym?" | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of DataFamilyTyCon -> TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing --always kind '*'+ -- placeHolderKind _ -> error "synifyTyCon: impossible open data type?" | otherwise = -- (closed) type, newtype, and data@@ -161,7 +164,7 @@ syn_type = synifyType WithinType (synTyConType tc) in if isSynTyCon tc then TySynonym name tyvars typats syn_type- else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv+ else TyData alg_nd alg_ctx name tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv -- User beware: it is your responsibility to pass True (use_gadt_syntax)@@ -224,25 +227,7 @@ synifyCtx :: [PredType] -> LHsContext Name-synifyCtx = noLoc . map synifyPred---synifyPred :: PredType -> LHsPred Name-synifyPred (ClassP cls tys) =- let sTys = map (synifyType WithinType) tys- in noLoc $- HsClassP (getName cls) sTys-synifyPred (IParam ip ty) =- let sTy = synifyType WithinType ty- -- IPName should be in class NamedThing...- in noLoc $- HsIParam ip sTy-synifyPred (EqPred ty1 ty2) =- let- s1 = synifyType WithinType ty1- s2 = synifyType WithinType ty2- in noLoc $- HsEqualP s1 s2+synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]@@ -253,7 +238,7 @@ name = getName tv in if isLiftedTypeKind kind then UserTyVar name placeHolderKind- else KindedTyVar name kind+ else KindedTyVar name (synifyKind kind) placeHolderKind --states of what to do with foralls:@@ -273,16 +258,26 @@ synifyType :: SynifyTypeState -> Type -> LHsType Name-synifyType _ (PredTy{}) = --should never happen.- error "synifyType: PredTys are not, in themselves, source-level types." synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | isTupleTyCon tc, tyConArity tc == length tys =- noLoc $ HsTupleTy (tupleTyConBoxity tc) (map (synifyType WithinType) tys)+ noLoc $ HsTupleTy (case tupleTyConSort tc of+ BoxedTuple -> HsBoxedTuple+ ConstraintTuple -> HsConstraintTuple+ UnboxedTuple -> HsUnboxedTuple)+ (map (synifyType WithinType) tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty)+ -- ditto for implicit parameter tycons+ | Just ip <- tyConIP_maybe tc+ , [ty] <- tys+ = noLoc $ HsIParamTy ip (synifyType WithinType ty)+ -- and equalities+ | tc == eqTyCon+ , [ty1, ty2] <- tys+ = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))@@ -311,11 +306,13 @@ in noLoc $ HsForAllTy forallPlicitness sTvs sCtx sTau +synifyKind :: Kind -> LHsKind Name+synifyKind = synifyType (error "synifyKind") synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->- ([HsPred Name], Name, [HsType Name])+ ([HsType Name], Name, [HsType Name]) synifyInstHead (_, preds, cls, ts) =- ( map (unLoc . synifyPred) preds+ ( map (unLoc . synifyType WithinType) preds , getName cls , map (unLoc . synifyType WithinType) ts )
src/Haddock/GhcUtils.hs view
@@ -20,6 +20,7 @@ import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Foldable hiding (concatMap)+import Data.Function import Data.Traversable import Distribution.Compat.ReadP import Distribution.Text@@ -30,9 +31,7 @@ import Packages import Module import RdrName (GlobalRdrEnv)-#if MIN_VERSION_ghc(7,1,0) import GhcMonad (withSession)-#endif import HscTypes import UniqFM import GHC@@ -63,10 +62,6 @@ where str = packageIdString p -mkModuleNoPackage :: String -> Module-mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)-- lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of@@ -83,23 +78,17 @@ getMainDeclBinder :: HsDecl name -> [name]-getMainDeclBinder (TyClD d) = [tcdName d]+getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d] getMainDeclBinder (ValD d) =-#if __GLASGOW_HASKELL__ == 612- case collectAcc d [] of- [] -> []- (name:_) -> [unLoc name]-#else case collectHsBindBinders d of [] -> [] (name:_) -> [name]-#endif- getMainDeclBinder (SigD d) = sigNameNoLoc d-getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name]-getMainDeclBinder (ForD (ForeignExport _ _ _)) = []+getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]+getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] + -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the@@ -153,6 +142,11 @@ isInstD _ = False +isValD :: HsDecl a -> Bool+isValD (ValD _) = True+isValD _ = False++ declATs :: HsDecl a -> [a] declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d declATs _ = []@@ -179,6 +173,10 @@ reL = L undefined +before :: Located a -> Located a -> Bool+before = (<) `on` getLoc++ instance Foldable (GenLocated l) where foldMap f (L _ x) = f x @@ -265,7 +263,7 @@ -- | A variant of 'gbracket' where the return value from the first computation -- is not required. gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c-gbracket_ before after thing = gbracket before (const after) (const thing)+gbracket_ before_ after thing = gbracket before_ (const after) (const thing) -------------------------------------------------------------------------------
src/Haddock/Interface/AttachInstances.hs view
@@ -25,11 +25,7 @@ import Name import InstEnv import Class-#if MIN_VERSION_ghc(7,1,0) import GhcMonad (withSession)-#else-import HscTypes (withSession)-#endif import TysPrim( funTyCon ) import MonadUtils (liftIO) import TcRnDriver (tcRnGetInfo)@@ -77,20 +73,17 @@ -- TODO: capture this pattern in a function (when we have streamlined the -- handling of instances) lookupInstDoc name iface ifaceMap instIfaceMap =- case Map.lookup name (ifaceInstanceDocMap iface) of+ case Map.lookup name (ifaceDocMap iface) of Just doc -> Just doc Nothing -> case Map.lookup modName ifaceMap of Just iface2 ->- case Map.lookup name (ifaceInstanceDocMap iface2) of+ case Map.lookup name (ifaceDocMap iface2) of Just doc -> Just doc Nothing -> Nothing Nothing -> case Map.lookup modName instIfaceMap of- Just instIface ->- case Map.lookup name (instDocMap instIface) of- Just (doc, _) -> doc- Nothing -> Nothing+ Just instIface -> Map.lookup name (instDocMap instIface) Nothing -> Nothing where modName = nameModule name@@ -116,7 +109,6 @@ data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) --- TODO: should we support PredTy here? instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) instHead (_, _, cls, args) = (map argCount args, className cls, map simplify args)@@ -134,7 +126,6 @@ where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)- simplify _ = error "simplify" -- sortImage f = sortBy (\x y -> compare (f x) (f y))
src/Haddock/Interface/Create.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create@@ -18,13 +19,14 @@ import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn-import Haddock.Interface.ExtractFnArgDocs -import qualified Data.Map as Map+import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe+import Data.Monoid import Data.Ord+import Control.Applicative import Control.Monad import qualified Data.Traversable as Traversable @@ -38,19 +40,25 @@ -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'.-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap- -> ErrMsgGhc Interface+createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do - let ms = pm_mod_summary . tm_parsed_module $ tm- mi = moduleInfo tm- mdl = ms_mod ms- dflags = ms_hspp_opts ms- instances = modInfoInstances mi- exportedNames = modInfoExports mi- -- XXX: confirm always a Just.- Just (group_, _, optExports, optDocHeader) = renamedSource tm+ let ms = pm_mod_summary . tm_parsed_module $ tm+ mi = moduleInfo tm+ mdl = ms_mod ms+ dflags = ms_hspp_opts ms+ instances = modInfoInstances mi+ exportedNames = modInfoExports mi + -- The renamed source should always be available to us, but it's best+ -- to be on the safe side.+ (group_, mayExports, mayDocHeader) <-+ case renamedSource tm of+ Nothing -> do+ liftErrMsg $ tell [ "Warning: Renamed source is not available." ]+ return (emptyRnGroup, Nothing, Nothing)+ Just (x, _, y, z) -> return (x, y, z)+ -- The pattern-match should not fail, because createInterface is only -- done on loaded modules. Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)@@ -60,35 +68,35 @@ | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre optDocHeader- decls0 <- liftErrMsg $ declInfos dflags gre (topDecls group_)+ (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader - let localInsts = filter (nameIsLocalOrFrom mdl . getName) instances- declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ]- instanceDocMap = mkInstanceDocMap localInsts declDocs+ let declsWithDocs = topDecls group_+ (decls, _) = unzip declsWithDocs+ localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - decls = filterOutInstances decls0- declMap = mkDeclMap decls- exports0 = fmap (reverse . map unLoc) optExports+ maps@(docMap, argMap, subMap, declMap) <-+ liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs++ let exports0 = fmap (reverse . map unLoc) mayExports exports- | OptIgnoreExports `elem` opts = Nothing- | otherwise = exports0+ | OptIgnoreExports `elem` opts = Nothing+ | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls0+ liftErrMsg $ warnAboutFilteredDecls mdl decls - exportItems <- mkExportItems modMap mdl gre exportedNames decls declMap- exports instances instIfaceMap dflags+ exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports+ instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts - -- measure haddock documentation coverage.+ -- Measure haddock documentation coverage. let prunedExportItems0 = pruneExportItems exportItems haddockable = 1 + length exportItems -- module + exports haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 coverage = (haddockable, haddocked) - -- prune the export list to just those declarations that have+ -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. let prunedExportItems@@ -102,15 +110,17 @@ ifaceDoc = mbDoc, ifaceRnDoc = Nothing, ifaceOptions = opts,- ifaceRnDocMap = Map.empty,+ ifaceDocMap = docMap,+ ifaceArgMap = argMap,+ ifaceRnDocMap = M.empty,+ ifaceRnArgMap = M.empty, ifaceExportItems = prunedExportItems, ifaceRnExportItems = [], ifaceExports = exportedNames, ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap,- ifaceSubMap = mkSubMap declMap exportedNames,+ ifaceSubMap = subMap, ifaceInstances = instances,- ifaceInstanceDocMap = instanceDocMap, ifaceHaddockCoverage = coverage } @@ -147,158 +157,131 @@ -------------------------------------------------------------------------------- -mkInstanceDocMap :: [Instance] -> [(HsDecl name, doc)] -> Map Name doc-mkInstanceDocMap instances decls =- -- We relate Instances to InstDecls using the SrcSpans buried inside them.- -- That should work for normal user-written instances (from looking at GHC- -- sources). We can assume that commented instances are user-written.- -- This lets us relate Names (from Instances) to comments (associated- -- with InstDecls).- let docMap = Map.fromList [ (loc, doc)- | (InstD (InstDecl (L loc _) _ _ _), doc) <- decls ]-- in Map.fromList [ (name, doc) | inst <- instances- , let name = getName inst- , Just doc <- [ Map.lookup (getSrcSpan name) docMap ] ]+type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) --- | Make a sub map from a declaration map. Make sure we only include exported--- names.-mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name]-mkSubMap declMap exports =- Map.filterWithKey (\k _ -> k `elem` exports) (Map.map filterSubs declMap)+mkMaps :: DynFlags+ -> GlobalRdrEnv+ -> [Instance]+ -> [Name]+ -> [(LHsDecl Name, [HsDocString])]+ -> ErrMsgM Maps+mkMaps dflags gre instances exports decls = do+ (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls+ let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b+ f = M.fromListWith mappend . concat+ return (f dm, f am, f sm, f cm) where- filterSubs (_, _, subs) = [ sub | (sub, _) <- subs, sub `elem` exports ]----- Make a map from names to 'DeclInfo's. Exclude declarations that don't have--- names (e.g. instances and stand-alone documentation comments). Include--- subordinate names, but map them to their parent declarations.-mkDeclMap :: [DeclInfo] -> Map Name DeclInfo-mkDeclMap decls = Map.fromList . concat $- [ decls_ ++ subDecls- | (parent@(L _ d), doc, subs) <- decls- , let decls_ = [ (name, (parent, doc, subs)) | name <- declNames d ]- subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]- , not (isDocD d), not (isInstD d) ]-+ mappings (ldecl@(L _ decl), docs) = do+ doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs+ argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $+ lexParseRnHaddockComment dflags NormalHaddockComment gre -declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]-declInfos dflags gre decls =- forM decls $ \(parent@(L _ d), mbDocString) -> do- mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment- gre mbDocString- fnArgsDoc <- fmap (Map.mapMaybe id) $- Traversable.forM (getDeclFnArgDocs d) $- \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc+ let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ] - let subs_ = subordinates d- subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do- mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment- gre mbSubDocStr- subFnArgsDoc <- fmap (Map.mapMaybe id) $- Traversable.forM subFnArgsDocStr $- \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc- return (subName, (mbSubDoc, subFnArgsDoc))+ (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do+ mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr+ subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $+ lexParseRnHaddockComment dflags NormalHaddockComment gre+ return ((n, mbSubDoc), (n, subFnArgsDoc))) - return (parent, (mbDoc, fnArgsDoc), subs)+ let names = case decl of+ -- See note [2].+ InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap)+ _ -> filter (`elem` exports) (getMainDeclBinder decl) + let subNames = map fst subDocs+ dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ]+ am = [ (n, argDocs) | n <- names ] ++ subArgMap+ sm = [ (n, subNames) | n <- names ]+ cm = [ (n, [ldecl]) | n <- names ++ subNames ]+ return (dm, am, sm, cm) --- | If you know the HsDecl can't contain any docs--- (e.g., it was loaded from a .hi file and you don't have a .haddock file--- to help you find out about the subs or docs)--- then you can use this to get its subs.-subordinatesWithNoDocs :: HsDecl Name -> [(Name, DocForDecl Name)]-subordinatesWithNoDocs decl = map noDocs (subordinates decl)- where- -- check the condition... or shouldn't we be checking?- noDocs (n, doc1, doc2) | null doc1, Map.null doc2- = (n, noDocForDecl)- noDocs _ = error ("no-docs thing has docs! " ++ pretty decl)+ instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] -subordinates :: HsDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)]-subordinates (TyClD d) = classDataSubs d-subordinates _ = []+-- Note [2]:+------------+-- We relate Instances to InstDecls using the SrcSpans buried inside them.+-- That should work for normal user-written instances (from looking at GHC+-- sources). We can assume that commented instances are user-written.+-- This lets us relate Names (from Instances) to comments (associated+-- with InstDecls). -classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings, Map Int HsDocString)]-classDataSubs decl+subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]+subordinates (TyClD decl) | isClassDecl decl = classSubs | isDataDecl decl = dataSubs- | otherwise = [] where- classSubs = [ (name, doc, fnArgsDoc)- | (L _ d, doc) <- classDecls decl- , name <- declNames d- , let fnArgsDoc = getDeclFnArgDocs d ]- dataSubs = constrs ++ fields+ classSubs = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls decl+ , name <- getMainDeclBinder d, not (isValD d)+ ]+ dataSubs = constrs ++ fields where- cons = map unL $ tcdCons decl- -- should we use the type-signature of the constructor- -- and the docs of the fields to produce fnArgsDoc for the constr,- -- just in case someone exports it without exporting the type- -- and perhaps makes it look like a function? I doubt it.- constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, Map.empty)+ cons = map unL $ tcdCons decl+ constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ]- fields = [ (unL n, maybeToList $ fmap unL doc, Map.empty)+ fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons , ConDeclField n _ doc <- flds ]----- All the sub declarations of a class (that we handle), ordered by--- source location, with documentation attached if it exists.-classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)]-classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass+subordinates _ = [] -declsFromClass :: TyClDecl a -> [Located (HsDecl a)]-declsFromClass class_ = docs ++ defs ++ sigs ++ ats+-- | 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)+ ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)+ TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty)+ _ -> M.empty where- docs = mkDecls tcdDocs DocD class_- defs = mkDecls (bagToList . tcdMeths) ValD class_- sigs = mkDecls tcdSigs SigD class_- ats = mkDecls tcdATs TyClD class_+ 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+ go _ _ = M.empty -declNames :: HsDecl a -> [a]-declNames (TyClD d) = [tcdName d]-declNames (ForD (ForeignImport n _ _)) = [unLoc n]--- we have normal sigs only (since they are taken from ValBindsOut)-declNames (SigD sig) = sigNameNoLoc sig-declNames _ = error "unexpected argument to declNames"+-- | All the sub declarations of a class (that we handle), ordered by+-- source location, with documentation attached if it exists.+classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls+ where+ decls = docs ++ defs ++ sigs ++ ats+ docs = mkDecls tcdDocs DocD class_+ defs = mkDecls (bagToList . tcdMeths) ValD class_+ sigs = mkDecls tcdSigs SigD class_+ ats = mkDecls tcdATs TyClD class_ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]-topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup---filterOutInstances :: [(Located (HsDecl a), b, c)] -> [(Located (HsDecl a), b, c)]-filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d))+topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup --- | Take all declarations except pragmas, infix decls, rules and value--- bindings from an 'HsGroup'.-declsFromGroup :: HsGroup Name -> [Decl]-declsFromGroup group_ =-#if MIN_VERSION_ghc(7,0,2)- mkDecls (concat . hs_tyclds) TyClD group_ ++-#else- mkDecls hs_tyclds TyClD group_ ++-#endif- mkDecls hs_derivds DerivD group_ ++- mkDecls hs_defds DefD group_ ++- mkDecls hs_fords ForD group_ ++- mkDecls hs_docs DocD group_ ++- mkDecls hs_instds InstD group_ ++- mkDecls (typesigs . hs_valds) SigD group_+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.+ungroup :: HsGroup Name -> [LHsDecl Name]+ungroup group_ =+ mkDecls (concat . hs_tyclds) TyClD group_ +++ mkDecls hs_derivds DerivD group_ +++ mkDecls hs_defds DefD group_ +++ mkDecls hs_fords ForD group_ +++ mkDecls hs_docs DocD group_ +++ mkDecls hs_instds InstD group_ +++ mkDecls (typesigs . hs_valds) SigD group_ +++ mkDecls (valbinds . hs_valds) ValD group_ where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs typesigs _ = error "expected ValBindsOut" + valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds+ valbinds _ = error "expected ValBindsOut" + -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]@@ -310,11 +293,11 @@ sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls :: Module -> [(LHsDecl Name, b, c)] -> ErrMsgM ()+warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () warnAboutFilteredDecls mdl decls = do let modStr = moduleString mdl let typeInstances =- nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ]+ nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ] unless (null typeInstances) $ tell [@@ -323,7 +306,7 @@ ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls+ let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls , not (null ats) ] unless (null instances) $@@ -340,20 +323,21 @@ -- | Filter out declarations that we don't handle in Haddock-filterDecls :: [(Decl, doc)] -> [(Decl, doc)]+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls decls = filter (isHandled . unL . fst) decls where isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (SigD d) = isVanillaLSig (reL d)+ isHandled (ValD _) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD _) = True isHandled _ = False -- | Go through all class declarations and filter their sub-declarations-filterClasses :: [(Decl, doc)] -> [(Decl, doc)]+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where@@ -370,67 +354,21 @@ -- declaration. -------------------------------------------------------------------------------- -type MaybeDocStrings = [HsDocString]--- avoid [] because we're appending from the left (quadratic),--- and avoid adding another package dependency for haddock,--- so use the difference-list pattern-type MaybeDocStringsFast = MaybeDocStrings -> MaybeDocStrings-docStringEmpty :: MaybeDocStringsFast-docStringEmpty = id-docStringSingleton :: HsDocString -> MaybeDocStringsFast-docStringSingleton = (:)-docStringAppend :: MaybeDocStringsFast -> MaybeDocStringsFast -> MaybeDocStringsFast-docStringAppend = (.)-docStringToList :: MaybeDocStringsFast -> MaybeDocStrings-docStringToList = ($ []) --- | Collect the docs and attach them to the right declaration.-collectDocs :: [Decl] -> [(Decl, MaybeDocStrings)]-collectDocs = collect Nothing docStringEmpty--collect :: Maybe Decl -> MaybeDocStringsFast -> [Decl] -> [(Decl, MaybeDocStrings)]-collect d doc_so_far [] =- case d of- Nothing -> []- Just d0 -> finishedDoc d0 doc_so_far []--collect d doc_so_far (e:es) =- case e of- L _ (DocD (DocCommentNext str)) ->- case d of- Nothing -> collect d- (docStringAppend doc_so_far (docStringSingleton str))- es- Just d0 -> finishedDoc d0 doc_so_far (collect Nothing- (docStringSingleton str)- es)-- L _ (DocD (DocCommentPrev str)) -> collect d- (docStringAppend doc_so_far (docStringSingleton str))- es-- _ -> case d of- Nothing -> collect (Just e) doc_so_far es- Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) docStringEmpty es)-+-- | Collect docs and attach them to the right declarations.+collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]+collectDocs = go Nothing []+ where+ go Nothing _ [] = []+ go (Just prev) docs [] = finished prev docs []+ go prev docs ((L _ (DocD (DocCommentNext str))):ds)+ | Nothing <- prev = go Nothing (str:docs) ds+ | Just decl <- prev = finished decl docs (go Nothing [str] ds)+ go prev docs ((L _ (DocD (DocCommentPrev str))):ds) = go prev (str:docs) ds+ go Nothing docs (d:ds) = go (Just d) docs ds+ go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) --- This used to delete all DocD:s, unless doc was DocEmpty,--- which I suppose means you could kill a DocCommentNamed--- by:------ > -- | killer--- >--- > -- $victim------ Anyway I accidentally deleted the DocEmpty condition without--- realizing it was necessary for retaining some DocDs (at least--- DocCommentNamed), so I'm going to try just not testing any conditions--- and see if anything breaks. It really shouldn't break anything--- to keep more doc decls around, IMHO.------ -Isaac-finishedDoc :: Decl -> MaybeDocStringsFast -> [(Decl, MaybeDocStrings)] -> [(Decl, MaybeDocStrings)]-finishedDoc d doc rest = (d, docStringToList doc) : rest+ finished decl docs rest = (decl, reverse docs) : rest -- | Build the list of items that will become the documentation, from the@@ -444,19 +382,22 @@ -> Module -- this module -> GlobalRdrEnv -> [Name] -- exported names (orig)- -> [DeclInfo]- -> Map Name DeclInfo -- maps local names to declarations+ -> [LHsDecl Name]+ -> Maps -> Maybe [IE Name] -> [Instance] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name]-mkExportItems modMap thisMod gre exportedNames decls declMap- optExports _ instIfaceMap dflags =+mkExportItems+ modMap thisMod gre exportedNames decls0+ (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of- Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre decls+ Nothing -> fullModuleContents dflags gre maps decls Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports where+ decls = filter (not . isInstD . unLoc) decls0+ -- A type signature can have multiple names, like: -- foo, bar :: Types.. -- When going throug the exported names we have to take care to detect such@@ -471,7 +412,7 @@ lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) =- moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap+ moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ])@@ -479,7 +420,7 @@ ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]) lookupExport (IEDocNamed str) = liftErrMsg $- ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ])+ ifDoc (findNamedDoc str [ unL d | d <- decls ]) (\docStr -> ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]))@@ -494,8 +435,12 @@ declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of- Just (decl, doc, subs) ->- let declNames_ = getMainDeclBinder (unL decl)+ ([L _ (ValD _)], (doc, _)) -> do+ -- Top-level binding without type signature+ export <- hiValExportItem t doc+ return [export]+ (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->+ let declNames = getMainDeclBinder (unL decl) in case () of _ -- temp hack: we filter out separately exported ATs, since we haven't decided how@@ -505,7 +450,7 @@ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1].- | not $ t `elem` declNames_,+ | not $ t `elem` declNames, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++@@ -516,7 +461,7 @@ return [] -- normal case- | otherwise -> return [ mkExportDecl t (newDecl, doc, subs) ]+ | otherwise -> return [ mkExportDecl t newDecl docs_ ] where -- Since a single signature might refer to many names, we -- need to filter the ones that are actually exported. This@@ -528,118 +473,29 @@ -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. _ -> decl- Nothing -> do- -- If we can't find the declaration, it must belong to- -- another package- mbTyThing <- liftGhcToErrMsgGhc $ lookupName t- -- show the name as exported as well as the name's- -- defining module (because the latter is where we- -- looked for the .hi/.haddock). It's to help people- -- debugging after all, so good to show more info.- let exportInfoString =- moduleString thisMod ++ "." ++ getOccString t- ++ ": "- ++ pretty (nameModule t) ++ "." ++ getOccString t - case mbTyThing of- Nothing -> do- liftErrMsg $ tell- ["Warning: Couldn't find TyThing for exported "- ++ exportInfoString ++ "; not documenting."]- -- Is getting to here a bug in Haddock?- -- Aren't the .hi files always present?- return [ ExportNoDecl t [] ]- Just tyThing -> do- let hsdecl = tyThingToLHsDecl tyThing- -- This is not the ideal way to implement haddockumentation- -- for functions/values without explicit type signatures.- --- -- However I didn't find an easy way to implement it properly,- -- and as long as we're using lookupName it is going to find- -- the types of local inferenced binds. If we don't check for- -- this at all, then we'll get the "warning: couldn't find- -- .haddock" which is wrong.- --- -- The reason this is not an ideal implementation- -- (besides that we take a trip to desugared syntax and back- -- unnecessarily)- -- is that Haddock won't be able to detect doc-strings being- -- attached to such a function, such as,- --- -- > -- | this is an identity function- -- > id a = a- --- -- . It's more difficult to say what it ought to mean in cases- -- where multiple exports are bound at once, like- --- -- > -- | comment...- -- > (a, b) = ...- --- -- especially since in the export-list they might not even- -- be next to each other. But a proper implementation would- -- really need to find the type of *all* exports as well as- -- addressing all these issues. This implementation works- -- adequately. Do you see a way to improve the situation?- -- Please go ahead! I got stuck trying to figure out how to- -- get the 'PostTcType's that we want for all the bindings- -- of an HsBind (you get 'LHsBinds' from 'GHC.typecheckedSource'- -- for example).- --- -- But I might be missing something obvious. What's important- -- /here/ is that we behave reasonably when we run into one of- -- those exported type-inferenced values.- isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do- let mdl = nameModule t- if modulePackageId mdl == thisPackage dflags then- isLoaded (moduleName mdl)- else return False-- if isLocalAndTypeInferenced then do- -- I don't think there can be any subs in this case,- -- currently? But better not to rely on it.- let subs = subordinatesWithNoDocs (unLoc hsdecl)- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]- else- -- We try to get the subs and docs- -- from the installed interface of that package.- case Map.lookup (nameModule t) instIfaceMap of- -- It's Nothing in the cases where I thought- -- Haddock has already warned the user: "Warning: The- -- documentation for the following packages are not- -- installed. No links will be generated to these packages:- -- ..."- -- But I guess it was Cabal creating that warning. Anyway,- -- this is more serious than links: it's exported decls where- -- we don't have the docs that they deserve!+ -- Declaration from another package+ ([], _) -> do+ mayDecl <- hiDecl t+ case mayDecl of+ Nothing -> return [ ExportNoDecl t [] ]+ Just decl -> do+ -- We try to get the subs and docs+ -- from the installed .haddock file for that package.+ case M.lookup (nameModule t) instIfaceMap of+ Nothing -> do+ liftErrMsg $ tell+ ["Warning: Couldn't find .haddock for export " ++ pretty t]+ let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]+ return [ mkExportDecl t decl (noDocForDecl, subs_) ]+ Just iface -> do+ return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] - -- We could use 'subordinates' to find the Names of the subs- -- (with no docs). Is that necessary? Yes it is, otherwise- -- e.g. classes will be shown without their exported subs.- Nothing -> do- liftErrMsg $ tell- ["Warning: Couldn't find .haddock for exported "- ++ exportInfoString]- let subs = subordinatesWithNoDocs (unLoc hsdecl)- return [ mkExportDecl t (hsdecl, noDocForDecl, subs) ]- Just iface -> do- let subs = case Map.lookup t (instSubMap iface) of- Nothing -> []- Just x -> x- return [ mkExportDecl t- ( hsdecl- , fromMaybe noDocForDecl $- Map.lookup t (instDocMap iface)- , map (\subt ->- ( subt ,- fromMaybe noDocForDecl $- Map.lookup subt (instDocMap iface)- )- ) subs- )]+ _ -> return [] - mkExportDecl :: Name -> DeclInfo -> ExportItem Name- mkExportDecl n (decl, doc, subs) = decl'+ mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name+ mkExportDecl n decl (doc, subs) = decl' where decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' [] mdl = nameModule n@@ -650,16 +506,44 @@ isExported = (`elem` exportedNames) - findDecl :: Name -> Maybe DeclInfo+ findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n- | m == thisMod = Map.lookup n declMap- | otherwise = case Map.lookup m modMap of- Just iface -> Map.lookup n (ifaceDeclMap iface)- Nothing -> Nothing+ | m == thisMod, Just ds <- M.lookup n declMap =+ (ds, lookupDocs n docMap argMap subMap)+ | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =+ (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))+ | otherwise = ([], (noDocForDecl, [])) where m = nameModule n +hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))+hiDecl t = do+ mayTyThing <- liftGhcToErrMsgGhc $ lookupName t+ case mayTyThing of+ Nothing -> do+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t]+ return Nothing+ Just x -> return (Just (tyThingToLHsDecl x))+++hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)+hiValExportItem name doc = do+ mayDecl <- hiDecl name+ case mayDecl of+ Nothing -> return (ExportNoDecl name [])+ Just decl -> return (ExportDecl decl doc [] [])+++-- | Lookup docs for a declaration from maps.+lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])+lookupDocs name docMap argMap subMap =+ let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in+ let doc = (M.lookup name docMap, lookupArgMap name) in+ let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in+ (doc, subs)++ -- | Return all export items produced by an exported module. That is, we're -- interested in the exports produced by \"module B\" in such a scenario: --@@ -675,24 +559,25 @@ -- a single 'ExportModule' item. moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module- -> DynFlags -- ^ The flag used when typechecking A+ -> DynFlags -- ^ The flags used when typechecking A -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A- -> [DeclInfo] -- ^ All the declarations in A+ -> [LHsDecl Name] -- ^ All the declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages+ -> Maps -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap- | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre decls+moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps+ | m == thisMod = fullModuleContents dflags gre maps decls | otherwise =- case Map.lookup m ifaceMap of+ case M.lookup m ifaceMap of Just iface | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) | otherwise -> return [ ExportModule m ] - Nothing -> -- we have to try to find it in the installed interfaces- -- (external packages)- case Map.lookup expMod (Map.mapKeys moduleName instIfaceMap) of+ Nothing -> -- We have to try to find it in the installed interfaces+ -- (external packages).+ case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do liftErrMsg $@@ -721,23 +606,34 @@ -- (For more information, see Trac #69) -fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name]-fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem decls+fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]+fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =+ liftM catMaybes $ mapM mkExportItem decls where- mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do- mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr- return $ fmap (ExportGroup lev "") mbDoc- mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do- mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr- return $ fmap ExportDoc mbDoc- mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs []+ mkExportItem (L _ (DocD (DocGroup lev docStr))) = do+ mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr+ return $ fmap (ExportGroup lev "") mbDoc+ mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do+ mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr+ return $ fmap ExportDoc mbDoc+ mkExportItem (L _ (ValD d))+ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =+ -- Top-level binding without type signature.+ let (doc, _) = lookupDocs name docMap argMap subMap in+ fmap Just (hiValExportItem name doc)+ | otherwise = return Nothing+ mkExportItem decl+ | name:_ <- getMainDeclBinder (unLoc decl) =+ let (doc, subs) = lookupDocs name docMap argMap subMap in+ return $ Just (ExportDecl decl doc subs [])+ | otherwise = return Nothing -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble--- together a type signature for it...)-extractDecl :: Name -> Module -> Decl -> Decl+-- together a type signature for it...).+extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name extractDecl name mdl decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise =@@ -770,7 +666,7 @@ _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where lctxt = noLoc . ctxt- ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds+ ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" @@ -808,7 +704,7 @@ exportName _ = [] --- | Find a stand-alone documentation comment by its name+-- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) findNamedDoc name decls = search decls where
− src/Haddock/Interface/ExtractFnArgDocs.hs
@@ -1,49 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Haddock.Interface.ExtractFnArgDocs--- Copyright : (c) Isaac Dupree 2009,--- License : BSD-like------ Maintainer : haddock@projects.haskell.org--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------module Haddock.Interface.ExtractFnArgDocs (- getDeclFnArgDocs, getSigFnArgDocs, getTypeFnArgDocs-) where--import Haddock.Types--import qualified Data.Map as Map-import Data.Map (Map)--import GHC---- the type of Name doesn't matter, except in 6.10 where--- HsDocString = HsDoc Name, so we can't just say "HsDecl name" yet.--getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString-getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty-getDeclFnArgDocs (ForD (ForeignImport _ ty _)) = getTypeFnArgDocs ty-getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty-getDeclFnArgDocs _ = Map.empty--getSigFnArgDocs :: Sig Name -> Map Int HsDocString-getSigFnArgDocs (TypeSig _ ty) = getTypeFnArgDocs ty-getSigFnArgDocs _ = Map.empty--getTypeFnArgDocs :: LHsType Name -> Map Int HsDocString-getTypeFnArgDocs ty = getLTypeDocs 0 ty---getLTypeDocs :: Int -> LHsType Name -> Map Int HsDocString-getLTypeDocs n (L _ ty) = getTypeDocs n ty--getTypeDocs :: Int -> HsType Name -> Map Int HsDocString-getTypeDocs n (HsForAllTy _ _ _ ty) = getLTypeDocs n ty-getTypeDocs n (HsFunTy (L _ (HsDocTy _arg_type (L _ doc))) res_type) =- Map.insert n doc $ getLTypeDocs (n+1) res_type-getTypeDocs n (HsFunTy _ res_type) = getLTypeDocs (n+1) res_type-getTypeDocs n (HsDocTy _res_type (L _ doc)) = Map.singleton n doc-getTypeDocs _ _res_type = Map.empty-
src/Haddock/Interface/LexParseRn.hs view
@@ -8,27 +8,34 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------module Haddock.Interface.LexParseRn (- HaddockCommentType(..),- lexParseRnHaddockComment,- lexParseRnHaddockCommentList,- lexParseRnMbHaddockComment,- lexParseRnHaddockModHeader+module Haddock.Interface.LexParseRn+ ( HaddockCommentType(..)+ , lexParseRnHaddockComment+ , lexParseRnHaddockCommentList+ , lexParseRnMbHaddockComment+ , lexParseRnHaddockModHeader ) where + import Haddock.Types import Haddock.Lex import Haddock.Parse-import Haddock.Interface.Rn import Haddock.Interface.ParseModuleHeader import Haddock.Doc++import Control.Applicative import Data.Maybe import FastString import GHC+import Name+import Outputable import RdrName+import RnEnv + data HaddockCommentType = NormalHaddockComment | DocSectionComment + lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockCommentList dflags hty gre docStrs = do docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs@@ -38,6 +45,7 @@ DocEmpty -> return Nothing _ -> return (Just doc) + lexParseRnHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do@@ -50,23 +58,78 @@ Nothing -> do tell ["doc comment parse failed: "++str] return Nothing- Just doc -> return (Just (rnDoc gre doc))+ Just doc -> return (Just (rename gre doc)) + lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d + -- yes, you always get a HaddockModInfo though it might be empty lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader dflags gre mbStr = do- let failure = (emptyHaddockModInfo, Nothing)- case mbStr of- Nothing -> return failure- Just (L _ (HsDocString fs)) -> do- let str = unpackFS fs- case parseModuleHeader dflags str of- Left mess -> do- tell ["haddock module header parse failed: " ++ mess]- return failure- Right (info, doc) ->- return (rnHaddockModInfo gre info, Just (rnDoc gre doc))+ (hmi, docn) <-+ case mbStr of+ Nothing -> return failure+ Just (L _ (HsDocString fs)) -> do+ let str = unpackFS fs+ case parseModuleHeader dflags str of+ Left mess -> do+ tell ["haddock module header parse failed: " ++ mess]+ return failure+ Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))+ return (hmi { hmi_safety = safety }, docn)+ where+ safety = Just $ showPpr $ safeHaskell dflags+ failure = (emptyHaddockModInfo, Nothing)+++renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name+renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi }+++rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name+rename gre = rn+ where+ rn d = case d of+ DocAppend a b -> DocAppend (rn a) (rn b)+ DocParagraph doc -> DocParagraph (rn doc)+ DocIdentifier x -> do+ let choices = dataTcOccs x+ let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices+ case names of+ [] ->+ case choices of+ [] -> DocMonospaced (DocString (showSDoc $ ppr x))+ [a] -> outOfScope a+ a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b+ [a] -> DocIdentifier a+ a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b+ -- If an id can refer to multiple things, we give precedence to type+ -- constructors.+ DocEmphasis doc -> DocEmphasis (rn doc)+ DocMonospaced doc -> DocMonospaced (rn doc)+ DocUnorderedList docs -> DocUnorderedList (map rn docs)+ DocOrderedList docs -> DocOrderedList (map rn docs)+ DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]+ DocCodeBlock doc -> DocCodeBlock (rn doc)+ DocIdentifierUnchecked x -> DocIdentifierUnchecked x+ DocModule str -> DocModule str+ DocURL str -> DocURL str+ DocPic str -> DocPic str+ DocAName str -> DocAName str+ DocExamples e -> DocExamples e+ DocEmpty -> DocEmpty+ DocString str -> DocString str+++outOfScope :: RdrName -> Doc a+outOfScope x =+ case x of+ Unqual occ -> monospaced occ+ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)+ Orig _ occ -> monospaced occ+ Exact name -> monospaced name -- Shouldn't happen since x is out of scope+ where+ monospaced a = DocMonospaced (DocString (showSDoc $ ppr a))
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -59,7 +59,8 @@ hmi_description = docOpt, hmi_portability = portabilityOpt, hmi_stability = stabilityOpt,- hmi_maintainer = maintainerOpt+ hmi_maintainer = maintainerOpt,+ hmi_safety = Nothing }, doc) -- | This function is how we read keys.
src/Haddock/Interface/Rename.hs view
@@ -17,8 +17,8 @@ import GHC hiding (NoLink) import Name-import BasicTypes import Bag (emptyBag)+import BasicTypes ( IPName(..), ipNameName ) import Data.List import qualified Data.Map as Map hiding ( Map )@@ -36,30 +36,22 @@ let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) where fn env name = Map.insert name (ifaceMod iface) env - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)-- -- make instance docs into 'docForDecls'- instDocs = [ (name, (Just doc, Map.empty))- | (name, doc) <- Map.toList (ifaceInstanceDocMap iface) ]-- docs = Map.toList docMap ++ instDocs- renameMapElem (k,d) = do d' <- renameDocForDecl d; return (k, d')- -- rename names in the exported declarations to point to things that -- are closer to, or maybe even exported by, the current module. (renamedExportItems, missingNames1) = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - (rnDocMap, missingNames2)- = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs))+ (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) - (finalModuleDoc, missingNames3)+ (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))++ (finalModuleDoc, missingNames4) = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing.- missingNames = nub $ filter isExternalName- (missingNames1 ++ missingNames2 ++ missingNames3)+ missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much+ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API.@@ -77,6 +69,7 @@ return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap,+ ifaceRnArgMap = rnArgMap, ifaceRnExportItems = renamedExportItems } @@ -171,11 +164,10 @@ DocParagraph doc -> do doc' <- renameDoc doc return (DocParagraph doc')- DocIdentifier ids -> do- lkp <- getLookupRn- case [ n | (True, n) <- map lkp ids ] of- ids'@(_:_) -> return (DocIdentifier ids')- [] -> return (DocIdentifier (map Undocumented ids))+ DocIdentifier x -> do+ x' <- rename x+ return (DocIdentifier x')+ DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x) DocModule str -> return (DocModule str) DocEmphasis doc -> do doc' <- renameDoc doc@@ -208,29 +200,16 @@ renameFnArgsDoc = mapM renameDoc -renameLPred :: LHsPred Name -> RnM (LHsPred DocName)-renameLPred = mapM renamePred---renamePred :: HsPred Name -> RnM (HsPred DocName)-renamePred (HsClassP name types) = do- name' <- rename name- types' <- mapM renameLType types- return (HsClassP name' types')-renamePred (HsEqualP type1 type2) = do- type1' <- renameLType type1- type2' <- renameLType type2- return (HsEqualP type1' type2')-renamePred (HsIParam (IPName name) t) = do- name' <- rename name- t' <- renameLType t- return (HsIParam (IPName name') t')-- renameLType :: LHsType Name -> RnM (LHsType DocName) renameLType = mapM renameType +renameLKind :: LHsKind Name -> RnM (LHsKind DocName)+renameLKind = renameLType +renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))+renameMaybeLKind Nothing = return Nothing+renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just+ renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do@@ -254,22 +233,23 @@ HsListTy ty -> return . HsListTy =<< renameLType ty HsPArrTy ty -> return . HsPArrTy =<< renameLType ty+ HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)+ HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (L loc op) b -> do+ HsOpTy a (w, (L loc op)) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b- return (HsOpTy a' (L loc op') b')+ return (HsOpTy a' (w, (L loc op')) b') HsParTy ty -> return . HsParTy =<< renameLType ty - HsPredTy p -> return . HsPredTy =<< renamePred p- HsKindSig ty k -> do ty' <- renameLType ty- return (HsKindSig ty' k)+ k' <- renameLKind k+ return (HsKindSig ty' k') HsDocTy ty doc -> do ty' <- renameLType ty@@ -282,18 +262,19 @@ renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc tv) = do name' <- rename (hsTyVarName tv)- return $ L loc (replaceTyVarName tv name')+ tyvar' <- replaceTyVarName tv name' renameLKind+ return $ L loc tyvar' -renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName])+renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do- context' <- mapM renameLPred context+ context' <- mapM renameLType context return (L loc context') renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (preds, className, types) = do- preds' <- mapM renamePred preds+ preds' <- mapM renameType preds className' <- rename className types' <- mapM renameType types return (preds', className', types')@@ -330,19 +311,24 @@ lname' <- renameL lname return (ForeignType lname' b) - TyFamily flav lname ltyvars kind -> do+-- TyFamily flav lname ltyvars kind tckind -> do+ TyFamily flav lname ltyvars tckind -> do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars- return (TyFamily flav lname' ltyvars' kind)+-- kind' <- renameMaybeLKind kind+ tckind' <- renameMaybeLKind tckind+-- return (TyFamily flav lname' ltyvars' kind' tckind)+ return (TyFamily flav lname' ltyvars' tckind') TyData x lcontext lname ltyvars typats k cons _ -> do lcontext' <- renameLContext lcontext lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars typats' <- mapM (mapM renameLType) typats+ k' <- renameMaybeLKind k cons' <- mapM renameLCon cons -- I don't think we need the derivings, so we return Nothing- return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing)+ return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing) TySynonym lname ltyvars typats ltype -> do lname' <- renameL lname@@ -351,15 +337,16 @@ typats' <- mapM (mapM renameLType) typats return (TySynonym lname' ltyvars' typats' ltype') - ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do+ ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do lcontext' <- renameLContext lcontext lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats+ at_defs' <- mapM renameLTyClD at_defs -- we don't need the default methods or the already collected doc entities- return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' [])+ return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' []) where renameLCon (L loc con) = return . L loc =<< renameCon con@@ -410,14 +397,14 @@ renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)-renameForD (ForeignImport lname ltype x) = do+renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype- return (ForeignImport lname' ltype' x)-renameForD (ForeignExport lname ltype x) = do+ return (ForeignImport lname' ltype' co x)+renameForD (ForeignExport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLType ltype- return (ForeignExport lname' ltype' x)+ return (ForeignExport lname' ltype' co x) renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
− src/Haddock/Interface/Rn.hs
@@ -1,83 +0,0 @@-module Haddock.Interface.Rn ( rnDoc, rnHaddockModInfo ) where--import Haddock.Types--import RnEnv ( dataTcOccs )--import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )-import Name ( Name )-import Outputable ( ppr, showSDoc )--rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name-rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =- HaddockModInfo (fmap (rnDoc gre) desc) port stab maint--ids2string :: [RdrName] -> String-ids2string [] = []-ids2string (x:_) = showSDoc $ ppr x--data Id x = Id {unId::x}-instance Monad Id where (Id v)>>=f = f v; return = Id--rnDoc :: GlobalRdrEnv -> Doc RdrName -> Doc Name-rnDoc gre = unId . do_rn- where- do_rn doc_to_rn = case doc_to_rn of - - DocEmpty -> return DocEmpty-- DocAppend a b -> do- a' <- do_rn a - b' <- do_rn b- return (DocAppend a' b')-- DocString str -> return (DocString str)-- DocParagraph doc -> do- doc' <- do_rn doc- return (DocParagraph doc')-- DocIdentifier ids -> do- let choices = concatMap dataTcOccs ids- let gres = concatMap (\rdrName ->- map gre_name (lookupGRE_RdrName rdrName gre)) choices- case gres of- [] -> return (DocMonospaced (DocString (ids2string ids)))- ids' -> return (DocIdentifier ids')-- DocModule str -> return (DocModule str)-- DocEmphasis doc -> do- doc' <- do_rn doc- return (DocEmphasis doc')-- DocMonospaced doc -> do- doc' <- do_rn doc - return (DocMonospaced doc')- - DocUnorderedList docs -> do- docs' <- mapM do_rn docs- return (DocUnorderedList docs')-- DocOrderedList docs -> do- docs' <- mapM do_rn docs- return (DocOrderedList docs')-- DocDefList list -> do- list' <- mapM (\(a,b) -> do- a' <- do_rn a- b' <- do_rn b- return (a', b')) list- return (DocDefList list')-- DocCodeBlock doc -> do- doc' <- do_rn doc- return (DocCodeBlock doc')-- DocURL str -> return (DocURL str)-- DocPic str -> return (DocPic str)-- DocAName str -> return (DocAName str)-- DocExamples e -> return (DocExamples e)
src/Haddock/InterfaceFile.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -14,7 +15,7 @@ module Haddock.InterfaceFile ( InterfaceFile(..), ifPackageId, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,- writeInterfaceFile+ writeInterfaceFile, binaryInterfaceVersion ) where @@ -30,14 +31,13 @@ import GHC hiding (NoLink) import Binary+import BinIface (getSymtabName, getDictFastString) import Name import UniqSupply import UniqFM import IfaceEnv import HscTypes-#if MIN_VERSION_ghc(7,1,0) import GhcMonad (withSession)-#endif import FastMutInt import FastString import Unique@@ -64,14 +64,14 @@ -- because we store GHC datatypes in our interface files, we need to make sure -- we version our interface files accordingly. binaryInterfaceVersion :: Word16-#if __GLASGOW_HASKELL__ == 700-binaryInterfaceVersion = 16-#elif __GLASGOW_HASKELL__ == 701-binaryInterfaceVersion = 16-#elif __GLASGOW_HASKELL__ == 702-binaryInterfaceVersion = 16+#if __GLASGOW_HASKELL__ == 702+binaryInterfaceVersion = 19 #elif __GLASGOW_HASKELL__ == 703-binaryInterfaceVersion = 16+binaryInterfaceVersion = 19+#elif __GLASGOW_HASKELL__ == 704+binaryInterfaceVersion = 19+#elif __GLASGOW_HASKELL__ == 705+binaryInterfaceVersion = 19 #else #error Unknown GHC version #endif@@ -108,10 +108,10 @@ let bin_dict = BinDictionary { bin_dict_next = dict_next_ref, bin_dict_map = dict_map_ref }- ud <- newWriteState (putName bin_symtab) (putFastString bin_dict) -- put the main thing- bh <- return $ setUserData bh0 ud+ bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab)+ (putFastString bin_dict) put_ bh iface -- write the symtab pointer at the front of the file@@ -170,9 +170,11 @@ -- monad being used. The exact monad is whichever monad the first -- argument, the getter and setter of the name cache, requires. ---readInterfaceFile :: MonadIO m =>- NameCacheAccessor m- -> FilePath -> m (Either String InterfaceFile)+readInterfaceFile :: forall m.+ MonadIO m+ => NameCacheAccessor m+ -> FilePath+ -> m (Either String InterfaceFile) readInterfaceFile (get_name_cache, set_name_cache) filename = do bh0 <- liftIO $ readBinMem filename @@ -184,23 +186,38 @@ "Magic number mismatch: couldn't load interface file: " ++ filename | version /= binaryInterfaceVersion -> return . Left $ "Interface file is of wrong version: " ++ filename- | otherwise -> do+ | otherwise -> with_name_cache $ \update_nc -> do dict <- get_dictionary bh0- bh1 <- init_handle_user_data bh0 dict-- theNC <- get_name_cache- (nc', symtab) <- get_symbol_table bh1 theNC- set_name_cache nc'-- -- set the symbol table- let ud' = getUserData bh1- bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab}+ + -- read the symbol table so we are capable of reading the actual data+ bh1 <- do+ let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+ (getDictFastString dict)+ symtab <- update_nc (get_symbol_table bh1)+ return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)+ (getDictFastString dict) -- load the actual data- iface <- liftIO $ get bh2+ iface <- liftIO $ get bh1 return (Right iface) where+ with_name_cache :: forall a.+ ((forall n b. MonadIO n+ => (NameCache -> n (NameCache, b))+ -> n b)+ -> m a)+ -> m a+ with_name_cache act = do+ nc_var <- get_name_cache >>= (liftIO . newIORef)+ x <- act $ \f -> do+ nc <- liftIO $ readIORef nc_var+ (nc', x) <- f nc+ liftIO $ writeIORef nc_var nc'+ return x+ liftIO (readIORef nc_var) >>= set_name_cache+ return x+ get_dictionary bin_handle = liftIO $ do dict_p <- get bin_handle data_p <- tellBin bin_handle@@ -209,10 +226,6 @@ seekBin bin_handle data_p return dict - init_handle_user_data bin_handle dict = liftIO $ do- ud <- newReadState dict- return (setUserData bin_handle ud)- get_symbol_table bh1 theNC = liftIO $ do symtab_p <- get bh1 data_p' <- tellBin bh1@@ -346,10 +359,11 @@ instance Binary InstalledInterface where- put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do+ put_ bh (InstalledInterface modu info docMap argMap exps visExps opts subMap) = do put_ bh modu put_ bh info put_ bh docMap+ put_ bh argMap put_ bh exps put_ bh visExps put_ bh opts@@ -359,12 +373,13 @@ modu <- get bh info <- get bh docMap <- get bh+ argMap <- get bh exps <- get bh visExps <- get bh opts <- get bh subMap <- get bh - return (InstalledInterface modu info docMap+ return (InstalledInterface modu info docMap argMap exps visExps opts subMap) @@ -451,6 +466,9 @@ put_ bh (DocExamples ao) = do putByte bh 15 put_ bh ao+ put_ bh (DocIdentifierUnchecked x) = do+ putByte bh 16+ put_ bh x get bh = do h <- getByte bh case h of@@ -502,6 +520,9 @@ 15 -> do ao <- get bh return (DocExamples ao)+ 16 -> do+ x <- get bh+ return (DocIdentifierUnchecked x) _ -> fail "invalid binary data found" @@ -511,13 +532,15 @@ put_ bh (hmi_portability hmi) put_ bh (hmi_stability hmi) put_ bh (hmi_maintainer hmi)+ put_ bh (hmi_safety hmi) get bh = do descr <- get bh porta <- get bh stabi <- get bh maint <- get bh- return (HaddockModInfo descr porta stabi maint)+ safet <- get bh+ return (HaddockModInfo descr porta stabi maint safet) instance Binary DocName where
src/Haddock/Lex.x view
@@ -121,7 +121,7 @@ | TokDefStart | TokDefEnd | TokSpecial Char- | TokIdent [RdrName]+ | TokIdent RdrName | TokString String | TokURL String | TokPic String@@ -209,7 +209,7 @@ ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags loc id of+ case parseIdent dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str)@@ -220,16 +220,12 @@ AlexPn _ line col -> mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName]-strToHsQNames dflags loc str0 = -#if MIN_VERSION_ghc(7,1,0)+parseIdent :: DynFlags -> RealSrcLoc -> String -> Maybe RdrName+parseIdent dflags loc str0 = let buffer = stringToStringBuffer str0-#else- let buffer = unsafePerformIO (stringToStringBuffer str0)-#endif pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of - POk _ name -> Just [unLoc name] + POk _ name -> Just (unLoc name) _ -> Nothing }
src/Haddock/Options.hs view
@@ -62,6 +62,7 @@ | Flag_Help | Flag_Verbosity String | Flag_Version+ | Flag_InterfaceVersion | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String@@ -71,6 +72,7 @@ | Flag_OptGhc String | Flag_GhcLibDir String | Flag_GhcVersion+ | Flag_PrintGhcPath | Flag_PrintGhcLibDir | Flag_NoWarnings | Flag_UseUnicode@@ -129,6 +131,8 @@ "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) "output version information and exit",+ Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)+ "output interface file version and exit", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")@@ -147,6 +151,8 @@ "option to be forwarded to GHC", Option [] ["ghc-version"] (NoArg Flag_GhcVersion) "output GHC version in numeric format",+ Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath)+ "output path to GHC binary", Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) "output GHC lib dir", Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
src/Haddock/Types.hs view
@@ -25,7 +25,9 @@ import Data.Typeable import Data.Map (Map) import qualified Data.Map as Map+import Data.Monoid import GHC hiding (NoLink)+import OccName -----------------------------------------------------------------------------@@ -34,10 +36,12 @@ type IfaceMap = Map Module Interface-type InstIfaceMap = Map Module InstalledInterface-type DocMap = Map Name (Doc DocName)+type InstIfaceMap = Map Module InstalledInterface -- TODO: rename+type DocMap a = Map Name (Doc a)+type ArgMap a = Map Name (Map Int (Doc a))+type SubMap = Map Name [Name]+type DeclMap = Map Name [LHsDecl Name] type SrcMap = Map PackageId FilePath-type Decl = LHsDecl Name type GhcDocHdr = Maybe LHsDocString type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -75,12 +79,18 @@ -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations.- , ifaceDeclMap :: Map Name DeclInfo+ , ifaceDeclMap :: Map Name [LHsDecl Name] -- | Documentation of declarations originating from the module (including -- subordinates).- , ifaceRnDocMap :: Map Name (DocForDecl DocName)+ , ifaceDocMap :: DocMap Name+ , ifaceArgMap :: ArgMap Name + -- | Documentation of declarations originating from the module (including+ -- subordinates).+ , ifaceRnDocMap :: DocMap DocName+ , ifaceRnArgMap :: ArgMap DocName+ , ifaceSubMap :: Map Name [Name] , ifaceExportItems :: ![ExportItem Name]@@ -97,9 +107,6 @@ -- | Instances exported by the module. , ifaceInstances :: ![Instance] - -- | Documentation of instances defined in the module.- , ifaceInstanceDocMap :: Map Name (Doc Name)- -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. , ifaceHaddockCoverage :: (Int,Int)@@ -118,8 +125,10 @@ -- | Documentation of declarations originating from the module (including -- subordinates).- , instDocMap :: Map Name (DocForDecl Name)+ , instDocMap :: DocMap Name + , instArgMap :: ArgMap Name+ -- | All names exported by this module. , instExports :: [Name] @@ -140,7 +149,8 @@ toInstalledIface interface = InstalledInterface { instMod = ifaceMod interface , instInfo = ifaceInfo interface- , instDocMap = fmap unrenameDocForDecl $ ifaceRnDocMap interface+ , instDocMap = ifaceDocMap interface+ , instArgMap = ifaceArgMap interface , instExports = ifaceExports interface , instVisibleExports = ifaceVisibleExports interface , instOptions = ifaceOptions interface@@ -202,11 +212,6 @@ | ExportModule Module --- | A declaration that may have documentation, including its subordinates,--- which may also have documentation.-type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)])-- -- | 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)@@ -259,7 +264,7 @@ -- | The head of an instance. Consists of a context, a class name and a list -- of instance types.-type InstHead name = ([HsPred name], name, [HsType name])+type InstHead name = ([HsType name], name, [HsType name]) -----------------------------------------------------------------------------@@ -275,7 +280,8 @@ | DocAppend (Doc id) (Doc id) | DocString String | DocParagraph (Doc id)- | DocIdentifier [id]+ | DocIdentifier id+ | DocIdentifierUnchecked (ModuleName, OccName) | DocModule String | DocEmphasis (Doc id) | DocMonospaced (Doc id)@@ -287,9 +293,14 @@ | DocPic String | DocAName String | DocExamples [Example]- deriving (Eq, Show, Functor)+ deriving (Functor) +instance Monoid (Doc id) where+ mempty = DocEmpty+ mappend = DocAppend++ unrenameDoc :: Doc DocName -> Doc Name unrenameDoc = fmap getName @@ -306,22 +317,23 @@ data DocMarkup id a = Markup- { markupEmpty :: a- , markupString :: String -> a- , markupParagraph :: a -> a- , markupAppend :: a -> a -> a- , markupIdentifier :: [id] -> a- , markupModule :: String -> a- , markupEmphasis :: a -> a- , markupMonospaced :: a -> a- , markupUnorderedList :: [a] -> a- , markupOrderedList :: [a] -> a- , markupDefList :: [(a,a)] -> a- , markupCodeBlock :: a -> a- , markupURL :: String -> a- , markupAName :: String -> a- , markupPic :: String -> a- , markupExample :: [Example] -> a+ { markupEmpty :: a+ , markupString :: String -> a+ , markupParagraph :: a -> a+ , markupAppend :: a -> a -> a+ , markupIdentifier :: id -> a+ , markupIdentifierUnchecked :: (ModuleName, OccName) -> a+ , markupModule :: String -> a+ , markupEmphasis :: a -> a+ , markupMonospaced :: a -> a+ , markupUnorderedList :: [a] -> a+ , markupOrderedList :: [a] -> a+ , markupDefList :: [(a,a)] -> a+ , markupCodeBlock :: a -> a+ , markupURL :: String -> a+ , markupAName :: String -> a+ , markupPic :: String -> a+ , markupExample :: [Example] -> a } @@ -330,6 +342,7 @@ , hmi_portability :: Maybe String , hmi_stability :: Maybe String , hmi_maintainer :: Maybe String+ , hmi_safety :: Maybe String } @@ -339,6 +352,7 @@ , hmi_portability = Nothing , hmi_stability = Nothing , hmi_maintainer = Nothing+ , hmi_safety = Nothing }
src/Haddock/Utils.hs view
@@ -17,7 +17,7 @@ toDescription, toInstalledDescription, -- * Filename utilities- moduleHtmlFile,+ moduleHtmlFile, moduleHtmlFile', contentsHtmlFile, indexHtmlFile, frameIndexHtmlFile, moduleIndexFrameName, mainFrameName, synopsisFrameName,@@ -25,7 +25,7 @@ jsFile, framesFile, -- * Anchor and URL utilities- moduleNameUrl, moduleUrl,+ moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, @@ -33,7 +33,7 @@ getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, -- * HTML cross reference mapping- html_xrefs_ref,+ html_xrefs_ref, html_xrefs_ref', -- * Doc markup markup,@@ -172,17 +172,26 @@ -------------------------------------------------------------------------------- +baseName :: ModuleName -> FilePath+baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString++ moduleHtmlFile :: Module -> FilePath moduleHtmlFile mdl = case Map.lookup mdl html_xrefs of- Nothing -> mdl' ++ ".html"- Just fp0 -> HtmlPath.joinPath [fp0, mdl' ++ ".html"]+ Nothing -> baseName mdl' ++ ".html"+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"] where- mdl' = map (\c -> if c == '.' then '-' else c)- (moduleNameString (moduleName mdl))+ mdl' = moduleName mdl +moduleHtmlFile' :: ModuleName -> FilePath+moduleHtmlFile' mdl =+ case Map.lookup mdl html_xrefs' of+ Nothing -> baseName mdl ++ ".html"+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] + contentsHtmlFile, indexHtmlFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html"@@ -229,6 +238,10 @@ moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n +moduleNameUrl' :: ModuleName -> OccName -> String+moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n++ nameAnchorId :: OccName -> String nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) where prefix | isValOcc name = 'v'@@ -353,11 +366,21 @@ html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) +{-# NOINLINE html_xrefs_ref' #-}+html_xrefs_ref' :: IORef (Map ModuleName FilePath)+html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map"))++ {-# NOINLINE html_xrefs #-} html_xrefs :: Map Module FilePath html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) +{-# NOINLINE html_xrefs' #-}+html_xrefs' :: Map ModuleName FilePath+html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref')++ ----------------------------------------------------------------------------- -- * List utils -----------------------------------------------------------------------------@@ -380,22 +403,23 @@ markup :: DocMarkup id a -> Doc id -> a-markup m DocEmpty = markupEmpty m-markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)-markup m (DocString s) = markupString m s-markup m (DocParagraph d) = markupParagraph m (markup m d)-markup m (DocIdentifier ids) = markupIdentifier m ids-markup m (DocModule mod0) = markupModule m mod0-markup m (DocEmphasis d) = markupEmphasis m (markup m d)-markup m (DocMonospaced d) = markupMonospaced m (markup m d)-markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)-markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)-markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)-markup m (DocURL url) = markupURL m url-markup m (DocAName ref) = markupAName m ref-markup m (DocPic img) = markupPic m img-markup m (DocExamples e) = markupExample m e+markup m DocEmpty = markupEmpty m+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)+markup m (DocString s) = markupString m s+markup m (DocParagraph d) = markupParagraph m (markup m d)+markup m (DocIdentifier x) = markupIdentifier m x+markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x+markup m (DocModule mod0) = markupModule m mod0+markup m (DocEmphasis d) = markupEmphasis m (markup m d)+markup m (DocMonospaced d) = markupMonospaced m (markup m d)+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)+markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)+markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)+markup m (DocURL url) = markupURL m url+markup m (DocAName ref) = markupAName m ref+markup m (DocPic img) = markupPic m img+markup m (DocExamples e) = markupExample m e markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)@@ -405,22 +429,23 @@ -- | The identity markup idMarkup :: DocMarkup a (Doc a) idMarkup = Markup {- markupEmpty = DocEmpty,- markupString = DocString,- markupParagraph = DocParagraph,- markupAppend = DocAppend,- markupIdentifier = DocIdentifier,- markupModule = DocModule,- markupEmphasis = DocEmphasis,- markupMonospaced = DocMonospaced,- markupUnorderedList = DocUnorderedList,- markupOrderedList = DocOrderedList,- markupDefList = DocDefList,- markupCodeBlock = DocCodeBlock,- markupURL = DocURL,- markupAName = DocAName,- markupPic = DocPic,- markupExample = DocExamples+ markupEmpty = DocEmpty,+ markupString = DocString,+ markupParagraph = DocParagraph,+ markupAppend = DocAppend,+ markupIdentifier = DocIdentifier,+ markupIdentifierUnchecked = DocIdentifierUnchecked,+ markupModule = DocModule,+ markupEmphasis = DocEmphasis,+ markupMonospaced = DocMonospaced,+ markupUnorderedList = DocUnorderedList,+ markupOrderedList = DocOrderedList,+ markupDefList = DocDefList,+ markupCodeBlock = DocCodeBlock,+ markupURL = DocURL,+ markupAName = DocAName,+ markupPic = DocPic,+ markupExample = DocExamples }
src/Main.hs view
@@ -50,7 +50,7 @@ #ifdef IN_GHC_TREE import System.FilePath #else-import GHC.Paths+import qualified GHC.Paths as GhcPaths import Paths_haddock #endif @@ -60,7 +60,9 @@ import Panic (panic, handleGhcException) import Module +import Control.Monad.Fix (MonadFix) + -------------------------------------------------------------------------------- -- * Exception handling --------------------------------------------------------------------------------@@ -153,7 +155,7 @@ readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do- libDir <- getGhcLibDir flags+ libDir <- fmap snd (getGhcDirs flags) -- Catches all GHC source errors, then prints and re-throws them. let handleSrcErrors action' = flip handleSourceError action' $ \err -> do@@ -226,7 +228,7 @@ when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls- allVisibleIfaces True prologue pretty+ allVisibleIfaces True prologue pretty opt_qualification copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do@@ -251,7 +253,7 @@ ------------------------------------------------------------------------------- -readInterfaceFiles :: MonadIO m =>+readInterfaceFiles :: (MonadFix m, MonadIO m) => NameCacheAccessor m -> [(DocPaths, FilePath)] -> m [(DocPaths, InterfaceFile)]@@ -327,35 +329,47 @@ case [str | Flag_Lib str <- flags] of [] -> #ifdef IN_GHC_TREE- getInTreeLibDir+ getInTreeDir #else getDataDir -- provided by Cabal #endif fs -> return (last fs) -getGhcLibDir :: [Flag] -> IO String-getGhcLibDir flags =+getGhcDirs :: [Flag] -> IO (String, String)+getGhcDirs flags = do case [ dir | Flag_GhcLibDir dir <- flags ] of- [] ->+ [] -> do #ifdef IN_GHC_TREE- getInTreeLibDir+ libDir <- getInTreeDir+ return (ghcPath, libDir) #else- return libdir -- from GHC.Paths+ return (ghcPath, GhcPaths.libdir) #endif- xs -> return $ last xs+ xs -> return (ghcPath, last xs)+ where+#ifdef IN_GHC_TREE+ ghcPath = "not available"+#else+ ghcPath = GhcPaths.ghc+#endif shortcutFlags :: [Flag] -> IO () shortcutFlags flags = do usage <- getUsage - when (Flag_Help `elem` flags) (bye usage)- when (Flag_Version `elem` flags) byeVersion- when (Flag_GhcVersion `elem` flags) byeGhcVersion+ when (Flag_Help `elem` flags) (bye usage)+ when (Flag_Version `elem` flags) byeVersion+ when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n"))+ when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) + when (Flag_PrintGhcPath `elem` flags) $ do+ dir <- fmap fst (getGhcDirs flags)+ bye $ dir ++ "\n"+ when (Flag_PrintGhcLibDir `elem` flags) $ do- dir <- getGhcLibDir flags+ dir <- fmap snd (getGhcDirs flags) bye $ dir ++ "\n" when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $@@ -377,14 +391,15 @@ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" ++ "Ported to use the GHC API by David Waern 2006-2008\n" - byeGhcVersion = bye (cProjectVersion ++ "\n") - updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()-updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping)+updateHTMLXRefs packages = do+ writeIORef html_xrefs_ref (Map.fromList mapping)+ writeIORef html_xrefs_ref' (Map.fromList mapping') where mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages , iface <- ifInstalledIfaces ifaces ]+ mapping' = [ (moduleName m, html) | (m, html) <- mapping ] getPrologue :: [Flag] -> IO (Maybe (Doc RdrName))@@ -402,16 +417,12 @@ #ifdef IN_GHC_TREE -getInTreeLibDir :: IO String-getInTreeLibDir = do+getInTreeDir :: IO String+getInTreeDir = do m <- getExecDir case m of- Nothing -> error "No GhcLibDir found"-#ifdef NEW_GHC_LAYOUT+ Nothing -> error "No GhcDir found" Just d -> return (d </> ".." </> "lib")-#else- Just d -> return (d </> "..")-#endif getExecDir :: IO (Maybe String)
tests/html-tests/runtests.hs view
@@ -1,17 +1,21 @@+import Control.Monad+import Data.List+import Data.Maybe+import Distribution.InstalledPackageInfo+import Distribution.Package+import Distribution.Simple.Compiler+import Distribution.Simple.GHC+import Distribution.Simple.PackageIndex+import Distribution.Simple.Program+import Distribution.Simple.Utils+import Distribution.Verbosity import System.Cmd+import System.Directory import System.Environment-import System.FilePath import System.Exit-import System.Directory+import System.FilePath import System.Process-import Data.List-import Control.Monad import Text.Printf-import Text.Regex-import Distribution.Simple.Utils-import Distribution.Simple.Program-import Distribution.Verbosity-import Data.Maybe packageRoot = "."@@ -28,7 +32,7 @@ test = do x <- doesFileExist haddockPath- when (not x) $ die "you need to run 'cabal build' successfully first"+ unless x $ die "you need to run 'cabal build' successfully first" contents <- getDirectoryContents testDir args <- getArgs@@ -51,17 +55,23 @@ waitForProcess h2 putStrLn "" - -- TODO: use Distribution.* to get the packages instead- libdir <- rawSystemStdout normal haddockPath ["--print-ghc-libdir"]- let librariesPath = ".."</>".."</>"share"</>"doc"</>"ghc"</>"html"</>"libraries"-- let mkDep name version =- let path = init libdir </> librariesPath </> name ++ "-" ++ version- in "-i " ++ path ++ "," ++ path </> name ++ ".haddock"+ -- TODO: maybe do something more clever here using haddock.cabal+ ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"]+ (_, conf) <- configure normal (Just ghcPath) Nothing defaultProgramConfiguration+ pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf+ let safeHead xs = case xs of x : _ -> Just x; [] -> Nothing+ let mkDep pkgName =+ maybe (error "Couldn't find test dependencies") id $ do+ let pkgs = lookupPackageName pkgIndex (PackageName pkgName)+ (_, pkgs') <- safeHead pkgs+ pkg <- safeHead pkgs'+ ifacePath <- safeHead (haddockInterfaces pkg)+ htmlPath <- safeHead (haddockHTMLs pkg)+ return ("-i " ++ htmlPath ++ "," ++ ifacePath) - let base = mkDep "base" "4.3.1.0"- process = mkDep "process" "1.0.1.5"- ghcprim = mkDep "ghc-prim" "0.2.0.0"+ let base = mkDep "base"+ process = mkDep "process"+ ghcprim = mkDep "ghc-prim" putStrLn "Running tests..." handle <- runProcess haddockPath@@ -107,9 +117,14 @@ haddockEq file1 file2 = stripLinks file1 == stripLinks file2 --stripLinks f = subRegex (mkRegexWithOpts "<A HREF=[^>]*>" False False) f "<A HREF=\"\">"-+stripLinks str =+ let prefix = "<a href=\"" in+ case stripPrefix prefix str of+ Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str')+ Nothing ->+ case str of+ [] -> []+ x : xs -> x : stripLinks xs programOnPath p = do result <- findProgramLocation silent p