diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -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
diff --git a/dist/build/haddock/haddock-tmp/Haddock/Lex.hs b/dist/build/haddock/haddock-tmp/Haddock/Lex.hs
--- a/dist/build/haddock/haddock-tmp/Haddock/Lex.hs
+++ b/dist/build/haddock/haddock-tmp/Haddock/Lex.hs
@@ -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
diff --git a/dist/build/haddock/haddock-tmp/Haddock/Parse.hs b/dist/build/haddock/haddock-tmp/Haddock/Parse.hs
--- a/dist/build/haddock/haddock-tmp/Haddock/Parse.hs
+++ b/dist/build/haddock/haddock-tmp/Haddock/Parse.hs
@@ -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
diff --git a/doc/haddock.xml b/doc/haddock.xml
--- a/doc/haddock.xml
+++ b/doc/haddock.xml
@@ -21,7 +21,7 @@
Simon Marlow, David Waern
- This document describes Haddock version 2.9.4, a Haskell
+ This document describes Haddock version 2.10.0, a Haskell
documentation tool.
diff --git a/haddock.cabal b/haddock.cabal
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -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
diff --git a/haddock.spec b/haddock.spec
--- a/haddock.spec
+++ b/haddock.spec
@@ -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}
diff --git a/html/Classic.theme/xhaddock.css b/html/Classic.theme/xhaddock.css
--- a/html/Classic.theme/xhaddock.css
+++ b/html/Classic.theme/xhaddock.css
@@ -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;
}
diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
--- a/src/Documentation/Haddock.hs
+++ b/src/Documentation/Haddock.hs
@@ -21,8 +21,6 @@
-- * Export items & declarations
ExportItem(..),
- Decl,
- DeclInfo,
DocForDecl,
FnArgsDoc,
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -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
}
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -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
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -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]
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -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
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -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
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -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.
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -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
)
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -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)
-------------------------------------------------------------------------------
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -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))
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -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
diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs
deleted file mode 100644
--- a/src/Haddock/Interface/ExtractFnArgDocs.hs
+++ /dev/null
@@ -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
-
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -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))
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -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.
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -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)
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
deleted file mode 100644
--- a/src/Haddock/Interface/Rn.hs
+++ /dev/null
@@ -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)
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -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
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -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
}
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -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",
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -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
}
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -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
}
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -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)
diff --git a/tests/html-tests/runtests.hs b/tests/html-tests/runtests.hs
--- a/tests/html-tests/runtests.hs
+++ b/tests/html-tests/runtests.hs
@@ -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 "]*>" False False) f ""
-
+stripLinks str =
+ let prefix = " prefix ++ stripLinks (dropWhile (/= '"') str')
+ Nothing ->
+ case str of
+ [] -> []
+ x : xs -> x : stripLinks xs
programOnPath p = do
result <- findProgramLocation silent p