aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs142
-rw-r--r--src/Haddock/Backends/LaTeX.hs138
-rw-r--r--src/Haddock/Backends/Xhtml.hs43
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs210
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs14
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs9
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs38
-rw-r--r--src/Haddock/Backends/Xhtml/Utils.hs15
-rw-r--r--src/Haddock/Convert.hs142
-rw-r--r--src/Haddock/GhcUtils.hs15
-rw-r--r--src/Haddock/Interface.hs4
-rw-r--r--src/Haddock/Interface/AttachInstances.hs9
-rw-r--r--src/Haddock/Interface/Create.hs376
-rw-r--r--src/Haddock/Interface/LexParseRn.hs102
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs7
-rw-r--r--src/Haddock/Interface/Rename.hs170
-rw-r--r--src/Haddock/InterfaceFile.hs65
-rw-r--r--src/Haddock/Lex.x3
-rw-r--r--src/Haddock/Options.hs16
-rw-r--r--src/Haddock/Parse.y13
-rw-r--r--src/Haddock/Types.hs137
-rw-r--r--src/Haddock/Utils.hs44
-rw-r--r--src/Main.hs80
23 files changed, 1006 insertions, 786 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 6e3e306a..4949daa1 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -34,24 +34,25 @@ prefix = ["-- Hoogle documentation, generated by Haddock"
,""]
-ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags package version synopsis prologue ifaces odir = do
let filename = package ++ ".txt"
contents = prefix ++
- docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
+ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
["@package " ++ package] ++
["@version " ++ version | version /= ""] ++
- concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
h <- openFile (odir </> filename) WriteMode
hSetEncoding h utf8
hPutStr h (unlines contents)
hClose h
-ppModule :: Interface -> [String]
-ppModule iface = "" : doc (ifaceDoc iface) ++
- ["module " ++ moduleString (ifaceMod iface)] ++
- concatMap ppExport (ifaceExportItems iface) ++
- concatMap ppInstance (ifaceInstances iface)
+ppModule :: DynFlags -> Interface -> [String]
+ppModule dflags iface =
+ "" : ppDocumentation dflags (ifaceDoc iface) ++
+ ["module " ++ moduleString (ifaceMod iface)] ++
+ concatMap (ppExport dflags) (ifaceExportItems iface) ++
+ concatMap (ppInstance dflags) (ifaceInstances iface)
---------------------------------------------------------------------
@@ -74,8 +75,8 @@ dropHsDocTy = f
f (HsDocTy a _) = f $ unL a
f x = x
-outHsType :: OutputableBndr a => HsType a -> String
-outHsType = out . dropHsDocTy
+outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
+outHsType dflags = out dflags . dropHsDocTy
makeExplicit :: HsType a -> HsType a
@@ -92,8 +93,8 @@ dropComment (x:xs) = x : dropComment xs
dropComment [] = []
-out :: Outputable a => a -> String
-out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
+out :: Outputable a => DynFlags -> a -> String
+out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
where
f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
f (x:xs) = x : f xs
@@ -101,111 +102,121 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
operator :: String -> String
-operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")"
+operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
operator x = x
---------------------------------------------------------------------
-- How to print each export
-ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
+ppExport :: DynFlags -> ExportItem Name -> [String]
+ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
- 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 (SigD sig) = ppSig sig
+ f (TyClD d@TyDecl{})
+ | isDataDecl d = ppData dflags d subdocs
+ | otherwise = ppSynonym dflags d
+ f (TyClD d@ClassDecl{}) = ppClass dflags d
+ f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (SigD sig) = ppSig dflags sig
f _ = []
-ppExport _ = []
+ppExport _ _ = []
-ppSig :: Sig Name -> [String]
-ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ]
+ppSig :: DynFlags -> Sig Name -> [String]
+ppSig dflags (TypeSig names sig)
+ = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
where
- prettyNames = concat . intersperse ", " $ map out names
+ prettyNames = intercalate ", " $ map (out dflags) names
typ = case unL sig of
HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
x -> x
-ppSig _ = []
-
-
-ppSynonym :: TyClDecl Name -> [String]
-ppSynonym x = [out x]
+ppSig _ _ = []
-- note: does not yet output documentation for class methods
-ppClass :: TyClDecl Name -> [String]
-ppClass x = out x{tcdSigs=[]} :
- concatMap (ppSig . addContext . unL) (tcdSigs x)
+ppClass :: DynFlags -> TyClDecl Name -> [String]
+ppClass dflags x = out dflags x{tcdSigs=[]} :
+ concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
where
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 : unLoc con)) d
- f t = HsForAllTy Implicit [] (reL [context]) (reL t)
+ f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
context = nlHsTyConApp (unL $ tcdLName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))
+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x)))
+
+ppInstance :: DynFlags -> ClsInst -> [String]
+ppInstance dflags x = [dropComment $ out dflags x]
-ppInstance :: Instance -> [String]
-ppInstance x = [dropComment $ out x]
+ppSynonym :: DynFlags -> TyClDecl Name -> [String]
+ppSynonym dflags x = [out dflags x]
-ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
- concatMap (ppCtor x subdocs . unL) (tcdCons x)
+ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
+ = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} :
+ concatMap (ppCtor dflags decl subdocs . unL) (td_cons defn)
where
+
-- GHC gives out "data Bar =", we want to delete the equals
-- also writes data : a b, when we want data (:) a b
showData d = unwords $ map f $ if last xs == "=" then init xs else xs
where
- xs = words $ out d
- nam = out $ tcdLName d
+ xs = words $ out dflags d
+ nam = out dflags $ tcdLName d
f w = if w == nam then operator nam else w
+ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
-lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name)
-lookupCon subdocs (L _ name) = case lookup name subdocs of
- Just (d, _) -> d
- _ -> Nothing
+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]
+lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
+ Just (d, _) -> ppDocumentation dflags d
+ _ -> []
-ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
+ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
+ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
++ f (con_details con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
- [doc (lookupCon subdocs (cd_fld_name r)) ++
- [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
+ [lookupCon dflags subdocs (cd_fld_name r) ++
+ [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
| r <- recs]
funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
apps = foldl1 (\x y -> reL $ HsAppTy x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds)
- name = out $ unL $ con_name con
+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+ name = out dflags $ unL $ con_name con
resType = case con_res con of
- ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [hsTyVarName v | v@UserTyVar {} <- map unL $ tcdTyVars dat]
+ ResTyH98 -> apps $ map (reL . HsTyVar) $
+ unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat]
ResTyGADT x -> x
---------------------------------------------------------------------
-- DOCUMENTATION
-doc :: Outputable o => Maybe (Doc o) -> [String]
-doc = docWith ""
+ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]
+ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w
+
+
+doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
+doc dflags = docWith dflags ""
-docWith :: Outputable o => String -> Maybe (Doc o) -> [String]
-docWith [] Nothing = []
-docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $
+docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]
+docWith _ [] Nothing = []
+docWith dflags header d
+ = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $
[header | header /= ""] ++ ["" | header /= "" && isJust d] ++
- maybe [] (showTags . markup markupTag) d
+ maybe [] (showTags . markup (markupTag dflags)) d
data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
@@ -226,15 +237,16 @@ str a = [Str a]
-- or inlne for others (a,i,tt)
-- entities (&,>,<) should always be appropriately escaped
-markupTag :: Outputable o => DocMarkup o [Tag]
-markupTag = Markup {
+markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]
+markupTag dflags = Markup {
markupParagraph = box TagP,
markupEmpty = str "",
markupString = str,
markupAppend = (++),
- markupIdentifier = box (TagInline "a") . str . out,
- markupIdentifierUnchecked = box (TagInline "a") . str . out . snd,
+ markupIdentifier = box (TagInline "a") . str . out dflags,
+ markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
markupModule = box (TagInline "a") . str,
+ markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
markupMonospaced = box (TagInline "tt"),
markupPic = const $ str " ",
@@ -242,7 +254,7 @@ markupTag = Markup {
markupOrderedList = box (TagL 'o'),
markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
markupCodeBlock = box TagPre,
- markupURL = box (TagInline "a") . str,
+ markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
markupAName = const $ str "",
markupExample = box TagPre . str . unlines . map exampleToString
}
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index e0a530be..68cf715a 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,6 @@ import GHC
import OccName
import Name ( nameOccName )
import RdrName ( rdrNameOcc )
-import BasicTypes ( ipNameName )
import FastString ( unpackFS, unpackLitString )
import qualified Data.Map as Map
@@ -158,9 +157,7 @@ ppLaTeXModule _title odir iface = do
]
description
- = case ifaceRnDoc iface of
- Nothing -> empty
- Just doc -> docToLaTeX doc
+ = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
body = processExports exports
--
@@ -210,7 +207,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
- (Nothing, argDocs) _ _)
+ (Documentation Nothing Nothing, argDocs) _ _)
| Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
@@ -276,40 +273,30 @@ ppDecl :: LHsDecl DocName
-> [(DocName, DocForDecl DocName)]
-> LaTeX
-ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
- TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode
- TyClD d@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode
- | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d
- TyClD d@(TySynonym {})
- | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode
- | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode
- TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode
- SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode
- ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode
+ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
+ TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode
+ TyClD d@(TyDecl{ tcdTyDefn = defn })
+ | isHsDataDefn defn -> ppDataDecl instances subdocs loc doc d unicode
+ | otherwise -> ppTySyn loc (doc, fnArgsDoc) d unicode
+-- Family instances happen via FamInst now
+-- TyClD d@(TySynonym {})
+-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
+-- Family instances happen via FamInst now
+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
+ SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+ ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
where
unicode = False
-ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
TyClDecl DocName -> Bool -> LaTeX
ppTyFam _ _ _ _ _ =
error "type family declarations are currently not supported by --latex"
-ppDataInst :: a
-ppDataInst =
- error "data instance declarations are currently not supported by --latex"
-
-
-ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) ->
- TyClDecl DocName -> Bool -> LaTeX
-ppTyInst _ _ _ _ _ =
- error "type instance declarations are currently not supported by --latex"
-
-
ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
ppFor _ _ _ _ =
error "foreign declarations are currently not supported by --latex"
@@ -323,7 +310,8 @@ ppFor _ _ _ _ =
-- we skip type patterns for now
ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
-ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode
+ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode
= ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
@@ -355,13 +343,13 @@ ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
unicode
| Map.null argDocs =
- declWithDoc pref1 (fmap docToLaTeX doc)
+ declWithDoc pref1 (documentationToLaTeX doc)
| otherwise =
declWithDoc pref2 $ Just $
text "\\haddockbeginargs" $$
do_args 0 sep0 typ $$
text "\\end{tabulary}\\par" $$
- maybe empty docToLaTeX doc
+ fromMaybe empty (documentationToLaTeX doc)
where
do_largs n leader (L _ t) = do_args n leader t
@@ -396,12 +384,12 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
-ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
+ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
ppTyVars tvs = map ppSymName (tyvarNames tvs)
-tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
-tyvarNames = map (getName . hsTyVarName . unLoc)
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -450,7 +438,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
@@ -469,10 +457,11 @@ ppFds fds unicode =
ppClassDecl :: [DocInstance DocName] -> SrcSpan
- -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+ -> Documentation DocName -> [(DocName, DocForDecl DocName)]
-> TyClDecl DocName -> Bool -> LaTeX
-ppClassDecl instances loc mbDoc subdocs
- (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode
+ppClassDecl instances loc doc subdocs
+ (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
+ , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
= declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
instancesBit
where
@@ -482,7 +471,7 @@ ppClassDecl instances loc mbDoc subdocs
hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
- body = catMaybes [fmap docToLaTeX mbDoc, body_]
+ body = catMaybes [documentationToLaTeX doc, body_]
body_
| null lsigs, null ats, null at_defs = Nothing
@@ -523,8 +512,8 @@ isUndocdInstance _ = Nothing
-- an 'argBox'. The comment is printed to the right of the box in normal comment
-- style.
ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, mbDoc) =
- declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc)
+ppDocInstance unicode (instHead, doc) =
+ declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)
ppInstDecl :: Bool -> InstHead DocName -> LaTeX
@@ -550,19 +539,19 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
ppDataDecl :: [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
LaTeX
-ppDataDecl instances subdocs _loc mbDoc dataDecl unicode
+ppDataDecl instances subdocs _loc doc dataDecl unicode
= declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
(if null body then Nothing else Just (vcat body))
$$ instancesBit
where
- cons = tcdCons dataDecl
+ cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
- body = catMaybes [constrBit, fmap docToLaTeX mbDoc]
+ body = catMaybes [constrBit, documentationToLaTeX doc]
(whereBit, leaders)
| null cons = (empty,[])
@@ -642,8 +631,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
forall = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- -- 'join' is in Maybe.
- mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
@@ -653,7 +641,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = join $ fmap fst $ lookup name subdocs
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
-- {-
-- ppHsFullConstr :: HsConDecl -> LaTeX
@@ -705,27 +693,15 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
-ppDataHeader decl unicode
- | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
- | otherwise =
- -- newtype or data
- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars
+ , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
- ppLContext (tcdCtxt decl) unicode <+>
+ ppLContext ctxt unicode <+>
-- T a b c ..., or a :+: b
- ppTyClBinderWithVars False decl
-
-
---------------------------------------------------------------------------------
--- * TyClDecl helpers
---------------------------------------------------------------------------------
-
-
--- | Print a type family / newtype / data / class binder and its variables
-ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX
-ppTyClBinderWithVars summ decl =
- ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
-
+ ppAppDocNameNames False name (tyvarNames tyvars)
+ppDataHeader _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
-- * Type applications
@@ -845,13 +821,13 @@ 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
-ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-> Located (HsContext DocName) -> Bool -> LaTeX
ppForAll expl tvs cxt unicode
| show_forall = forall_part <+> ppLContext cxt unicode
| otherwise = ppLContext cxt unicode
where
- show_forall = not (null tvs) && is_explicit
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False}
forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
@@ -872,7 +848,7 @@ ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) t
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 _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName 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"
@@ -903,6 +879,15 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode
ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
= ppr_mono_lty ctxt_prec ty unicode
+ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
+
+
+ppr_tylit :: HsTyLit -> Bool -> LaTeX
+ppr_tylit (HsNumTy n) _ = integer n
+ppr_tylit (HsStrTy s) _ = text (show s)
+ -- XXX: Ok in verbatim, but not otherwise
+ -- XXX: Do something with Unicode parameter?
+
ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
ppr_fun_ty ctxt_prec ty1 ty2 unicode
@@ -933,6 +918,8 @@ ppSymName name
ppVerbOccName :: OccName -> LaTeX
ppVerbOccName = text . latexFilter . occNameString
+ppIPName :: HsIPName -> LaTeX
+ppIPName ip = text $ unpackFS $ hsIPNameFS ip
ppOccName :: OccName -> LaTeX
ppOccName = text . occNameString
@@ -1006,6 +993,7 @@ parLatexMarkup ppId = Markup {
markupIdentifier = markupId ppId,
markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
+ markupWarning = \p v -> emph (p v),
markupEmphasis = \p v -> emph (p v),
markupMonospaced = \p _ -> tt (p Mono),
markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
@@ -1013,7 +1001,7 @@ parLatexMarkup ppId = Markup {
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),
+ markupHyperlink = \l _ -> markupLink l,
markupAName = \_ _ -> empty,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
}
@@ -1022,6 +1010,10 @@ parLatexMarkup ppId = Markup {
fixString Verb s = s
fixString Mono s = latexMonoFilter s
+ markupLink (Hyperlink url mLabel) = case mLabel of
+ Just label -> text "\\href" <> braces (text url) <> braces (text label)
+ Nothing -> text "\\url" <> braces (text url)
+
markupId ppId_ id v =
case v of
Verb -> theid
@@ -1042,6 +1034,10 @@ docToLaTeX :: Doc DocName -> LaTeX
docToLaTeX doc = markup latexMarkup doc Plain
+documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
+documentationToLaTeX = fmap docToLaTeX . combineDocumentation
+
+
rdrDocToLaTeX :: Doc RdrName -> LaTeX
rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 52bde5b6..c68b7cbc 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -66,7 +66,7 @@ ppHtml :: String
-> Maybe String -- ^ The contents URL (--use-contents)
-> Maybe String -- ^ The index URL (--use-index)
-> Bool -- ^ Whether to use unicode in output (--use-unicode)
- -> Qualification -- ^ How to qualify names
+ -> QualOption -- ^ How to qualify names
-> Bool -- ^ Output pretty html (newlines and indenting)
-> IO ()
@@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
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 qual
+ prologue debug (makeContentsQual qual)
when (isNothing maybe_index_url) $
ppHtmlIndex odir doctitle maybe_package
@@ -175,7 +175,7 @@ bodyHtml doctitle iface
contentsButton maybe_contents_url,
indexButton maybe_index_url])
! [theclass "links", identifier "page-menu"],
- nonEmpty sectionName << doctitle
+ nonEmptySectionName << doctitle
],
divContent << pageContent,
divFooter << paragraph << (
@@ -431,7 +431,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
indexLinks nm entries
many_entities ->
td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
- aboves (map doAnnotatedEntity (zip [1..] many_entities))
+ aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)
doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
doAnnotatedEntity (j,(nm,entries))
@@ -461,18 +461,16 @@ ppHtmlIndex odir doctitle _maybe_package themes
ppHtmlModule
:: FilePath -> String -> Themes
-> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool -> Qualification
+ -> Maybe String -> Maybe String -> Bool -> QualOption
-> Bool -> Interface -> IO ()
ppHtmlModule odir doctitle themes
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url unicode qual debug iface = do
let
mdl = ifaceMod iface
+ aliases = ifaceModuleAliases iface
mdl_str = moduleString mdl
- real_qual = case qual of
- LocalQual Nothing -> LocalQual (Just mdl)
- RelativeQual Nothing -> RelativeQual (Just mdl)
- _ -> qual
+ real_qual = makeModuleQual qual aliases mdl
html =
headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
bodyHtml doctitle (Just iface)
@@ -484,8 +482,7 @@ ppHtmlModule odir doctitle themes
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug
-
+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
-> Interface -> Bool -> Qualification -> Bool -> IO ()
@@ -511,18 +508,16 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
+ has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
no_doc_at_all = not (any has_doc exports)
- description
- = case ifaceRnDoc iface of
- Nothing -> noHtml
- Just doc -> divDescription $
- sectionName << "Description" +++ docSection qual doc
+ description | isNoHtml doc = doc
+ | otherwise = divDescription $ sectionName << "Description" +++ doc
+ where doc = docSection qual (ifaceRnDoc iface)
-- omit the synopsis if there are no documentation annotations at all
synopsis
@@ -539,7 +534,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
maybe_doc_hdr
= case exports of
[] -> noHtml
- ExportGroup _ _ _ : _ -> noHtml
+ ExportGroup {} : _ -> noHtml
_ -> h1 << "Documentation"
bdy =
@@ -562,12 +557,8 @@ 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 qual]
- (TyData{tcdTyPats = ps})
- | Nothing <- ps -> [keyword "data" <+> b]
- | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b]
- (TySynonym{tcdTyPats = ps})
- | Nothing <- ps -> [keyword "type" <+> b]
- | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b]
+ (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]
+ (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b]
(ClassDecl {}) -> [keyword "class" <+> b]
_ -> []
SigD (TypeSig lnames (L _ _)) ->
@@ -621,7 +612,7 @@ ppModuleContents qual exports
-- we need to assign a unique id to each section heading so we can hyperlink
-- them from the contents:
numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
-numberSectionHeadings exports = go 1 exports
+numberSectionHeadings = go 1
where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
go _ [] = []
go n (ExportGroup lev _ doc : es)
@@ -642,7 +633,7 @@ processExport summary _ _ qual (ExportNoDecl y subs)
= processDeclOneLiner summary $
ppDocName qual y +++ parenList (map (ppDocName qual) subs)
processExport summary _ _ qual (ExportDoc doc)
- = nothingIf summary $ docSection qual doc
+ = nothingIf summary $ docSection_ qual doc
processExport summary _ _ _ (ExportModule mdl)
= processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 686e9a3e..59be34f7 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -26,7 +26,6 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
-import Control.Monad ( join )
import Data.List ( intersperse )
import qualified Data.Map as Map
import Data.Maybe
@@ -34,21 +33,16 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC
import Name
-import BasicTypes ( ipNameName )
--- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual
- TyClD d@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
- TyClD d@(TySynonym {})
- | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
- | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual
+ TyClD d@(TyDecl{ tcdTyDefn = defn })
+ | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+ | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
@@ -73,14 +67,14 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html
ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual
| summary = pref1
- | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc
+ | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc
| otherwise = topDeclElem links loc docnames pref2 +++
- subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc
+ subArguments qual (do_args 0 sep typ) +++ docSection qual doc
where
argDoc n = Map.lookup n argDocs
do_largs n leader (L _ t) = do_args n leader t
- do_args :: Int -> Html -> (HsType DocName) -> [SubDecl]
+ do_args :: Int -> Html -> HsType DocName -> [SubDecl]
do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
= (leader <+>
hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
@@ -100,15 +94,15 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
= (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
- = (leader <+> ppType unicode qual t, argDoc n, []) : []
+ = [(leader <+> ppType unicode qual t, argDoc n, [])]
-ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
+ppTyVars :: LHsTyVarBndrs DocName -> [Html]
ppTyVars tvs = map ppTyName (tyvarNames tvs)
-tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
-tyvarNames = map (getName . hsTyVarName . unLoc)
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
@@ -121,7 +115,9 @@ ppFor _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
-> Qualification -> Html
-ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual
+ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdTyDefn = TySynonym { td_synRhs = ltype } })
+ unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full, hdr, spaceHtml +++ equals) unicode qual
where
@@ -163,17 +159,17 @@ ppTyFamHeader summary associated decl unicode qual =
ppTyClBinderWithVars summary decl <+>
- case tcdKind decl of
+ case tcdKindSig decl of
Just kind -> dcolon unicode <+> ppLKind unicode qual kind
- Nothing -> noHtml
+ Nothing -> noHtml
-ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
+ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->
TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links loc mbDoc decl unicode qual
+ppTyFam summary associated links loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
- | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit
+ | otherwise = header_ +++ docSection qual doc +++ instancesBit
where
docname = tcdName decl
@@ -187,50 +183,6 @@ ppTyFam summary associated links loc mbDoc decl unicode qual
--------------------------------------------------------------------------------
--- * Indexed data types
---------------------------------------------------------------------------------
-
-
-ppDataInst :: a
-ppDataInst = undefined
-
-
---------------------------------------------------------------------------------
--- * Indexed newtypes
---------------------------------------------------------------------------------
-
--- TODO
--- ppNewTyInst = undefined
-
-
---------------------------------------------------------------------------------
--- * Indexed types
---------------------------------------------------------------------------------
-
-
-ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) ->
- TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInst summary associated links loc mbDoc decl unicode qual
-
- | summary = ppTyInstHeader True associated decl unicode qual
- | otherwise = header_ +++ maybeDocSection qual mbDoc
-
- where
- docname = tcdName decl
-
- header_ = topDeclElem links loc [docname]
- (ppTyInstHeader summary associated decl unicode qual)
-
-
-ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppTyInstHeader _ _ decl unicode qual =
- keyword "type instance" <+>
- ppAppNameTypes (tcdName decl) typeArgs unicode qual
- where
- typeArgs = map unLoc . fromJust . tcdTyPats $ decl
-
-
---------------------------------------------------------------------------------
-- * Associated Types
--------------------------------------------------------------------------------
@@ -240,7 +192,6 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> B
ppAssocType summ links doc (L loc decl) unicode qual =
case decl of
TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual
- TySynonym {} -> ppTySyn summ links loc doc decl unicode qual
_ -> error "declaration type not supported by ppAssocType"
@@ -297,12 +248,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc
ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html
ppContextNoArrow [] _ _ = noHtml
-ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
+ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
ppContextNoLocs [] _ _ = noHtml
-ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual
+ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
<+> darrow unicode
@@ -310,10 +261,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html
ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
-pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
-pp_hs_context [] _ _ = noHtml
-pp_hs_context [p] unicode qual = ppType unicode qual p
-pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html
+ppHsContext [] _ _ = noHtml
+ppHsContext [p] unicode qual = ppType unicode qual p
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
-------------------------------------------------------------------------------
@@ -322,13 +273,13 @@ pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
-> Bool -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
<+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
- <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
- <+> ppFds fds unicode qual
+ <+> ppAppDocNameNames summ n (tyvarNames tvs)
+ <+> ppFds fds unicode qual
ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html
@@ -343,7 +294,8 @@ ppFds fds unicode qual =
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 { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
+ , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
subdocs unicode qual =
if null sigs && null ats
then (if summary then id else topDeclElem links loc [nm]) hdr
@@ -353,6 +305,8 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) lo
[ ppAssocType summary links doc at unicode qual | at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++
+ -- ToDo: add associated type defaults
+
[ ppFunSig summary links loc doc names typ unicode qual
| L _ (TypeSig lnames (L _ typ)) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
@@ -369,12 +323,13 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor
ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
- -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
+ -> Documentation 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
+ppClassDecl summary links instances loc d subdocs
+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs unicode qual
- | otherwise = classheader +++ maybeDocSection qual mbDoc
+ | otherwise = classheader +++ docSection qual d
+++ atBit +++ methodBit +++ instancesBit
where
classheader
@@ -385,6 +340,7 @@ ppClassDecl summary links instances loc mbDoc subdocs
hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
+ -- ToDo: add assocatied typ defaults
atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual
| at <- ats
, let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
@@ -397,7 +353,7 @@ ppClassDecl summary links instances loc mbDoc subdocs
-- there are different subdocs for different names in a single
-- type signature?
- instancesBit = ppInstances instances nm unicode qual
+ instancesBit = ppInstances instances nm unicode qual
ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
@@ -414,11 +370,8 @@ ppInstances instances baseName unicode qual
<+> ppAppNameTypes n ts unicode qual
-lookupAnySubdoc :: (Eq name1) =>
- name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
-lookupAnySubdoc n subdocs = case lookup n subdocs of
- Nothing -> noDocForDecl
- Just docs -> docs
+lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-------------------------------------------------------------------------------
@@ -431,7 +384,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool
-> Qualification -> Html
ppShortDataDecl summary _links _loc dataDecl unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons = dataHeader
| [lcon] <- cons, ResTyH98 <- resTy,
(cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual
@@ -448,22 +401,22 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual
doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
- cons = tcdCons dataDecl
+ cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
- SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
Qualification -> Html
-ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual
+ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
| summary = ppShortDataDecl summary links loc dataDecl unicode qual
- | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit
+ | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
where
docname = unLoc . tcdLName $ dataDecl
- cons = tcdCons dataDecl
+ cons = td_cons (tcdTyDefn dataDecl)
resTy = (con_res . unLoc . head) cons
header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
@@ -514,7 +467,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
-- (except each field gets its own line in docs, to match
-- non-GADT records)
RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
- ppForAll forall ltvs lcontext unicode qual <+> char '{',
+ ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
doRecordFields fields,
char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
@@ -522,29 +475,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of
where
doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields)
doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs lcontext unicode qual,
+ ppForAll forall_ ltvs lcontext unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
- header_ = ppConstrHdr forall tyVars context
+ header_ = ppConstrHdr forall_ tyVars context
occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames ltvs
lcontext = con_cxt con
context = unLoc (con_cxt con)
- forall = con_explicit con
+ forall_ = con_explicit con
mkFunTy a b = noLoc (HsFunTy a b)
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool
-> Qualification -> Html
-ppConstrHdr forall tvs ctxt unicode qual
+ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
+++
(if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
<+> darrow unicode +++ toHtml " ")
where
- ppForall = case forall of
+ ppForall = case forall_ of
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> noHtml
@@ -582,19 +535,18 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
doGADTCon args resTy =
ppBinder False occ <+> dcolon unicode
- <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual,
+ <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
- header_ = ppConstrHdr forall tyVars context
+ header_ = ppConstrHdr forall_ tyVars context
occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
- forall = con_explicit con
+ forall_ = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- -- 'join' is in Maybe.
- mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
@@ -606,7 +558,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
[])
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = join $ fmap fst $ lookup name subdocs
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html
@@ -618,15 +570,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
-- | Print the LHS of a data\/newtype declaration.
-- Currently doesn't handle 'data instance' decls or kind signatures
ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppDataHeader summary decl unicode qual
- | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
- | otherwise =
- -- newtype or data
- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } })
+ unicode qual
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
-- context
- ppLContext (tcdCtxt decl) unicode qual <+>
+ ppLContext ctxt unicode qual <+>
-- T a b c ..., or a :+: b
ppTyClBinderWithVars summary decl
+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
--------------------------------------------------------------------------------
@@ -652,13 +604,13 @@ tupleParens _ = parenList
pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
-pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC
-pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC
- -- Used for LH arg of (->)
-pREC_OP = (2 :: Int) -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = (3 :: Int) -- Used for arg of type applicn:
- -- always parenthesise unless atomic
+pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC
+pREC_FUN = 1 :: Int -- btype in ParseIface.y in GHC
+ -- Used for LH arg of (->)
+pREC_OP = 2 :: Int -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = 3 :: Int -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
maybeParen :: Int -- Precedence of context
-> Int -- Precedence of top-level operator
@@ -688,19 +640,19 @@ 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
-ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-> Located (HsContext DocName) -> Bool -> Qualification -> Html
ppForAll expl tvs cxt unicode qual
| show_forall = forall_part <+> ppLContext cxt unicode qual
| otherwise = ppLContext cxt unicode qual
where
- show_forall = not (null tvs) && is_explicit
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False}
forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html
-ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html
@@ -716,13 +668,9 @@ ppr_mono_ty _ (HsKindSig ty kind) u q =
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 _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName 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"
-#else
ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-#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
@@ -741,8 +689,8 @@ 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
- ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op
- occName = nameOccName . getName . unLoc $ op
+ ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op
+ occ = nameOccName . getName . unLoc $ op
ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
-- = parens (ppr_mono_lty pREC_TOP ty)
@@ -751,6 +699,12 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
= ppr_mono_lty ctxt_prec ty unicode qual
+ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+
+ppr_tylit :: HsTyLit -> Html
+ppr_tylit (HsNumTy n) = toHtml (show n)
+ppr_tylit (HsStrTy s) = toHtml (show s)
+
ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index f506d2b8..e75cfaba 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
rdrDocToHtml,
origDocToHtml,
- docElement, docSection, maybeDocSection,
+ docElement, docSection, docSection_,
) where
@@ -25,6 +25,7 @@ import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
+import Data.Maybe (fromMaybe)
import GHC
@@ -39,13 +40,14 @@ parHtmlMarkup qual ppId = Markup {
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
markupModule = \m -> let (mdl,ref) = break (=='#') m
in ppModuleRef (mkModuleName mdl) ref,
+ markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
markupMonospaced = thecode,
markupUnorderedList = unordList,
markupOrderedList = ordList,
markupDefList = defList,
markupCodeBlock = pre,
- markupURL = \url -> anchor ! [href url] << url,
+ markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel,
markupAName = \aname -> namedAnchor aname << "",
markupPic = \path -> image ! [src path],
markupExample = examplesToHtml
@@ -84,12 +86,12 @@ docElement el content_ =
else el ! [theclass "doc"] << content_
-docSection :: Qualification -> Doc DocName -> Html
-docSection qual = (docElement thediv <<) . docToHtml qual
+docSection :: Qualification -> Documentation DocName -> Html
+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
-maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html
-maybeDocSection qual = maybe noHtml (docSection qual)
+docSection_ :: Qualification -> Doc DocName -> Html
+docSection_ qual = (docElement thediv <<) . docToHtml qual
cleanup :: Doc a -> Doc a
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index bdd5ac78..3ddbd28b 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -18,6 +18,7 @@ module Haddock.Backends.Xhtml.Layout (
divIndex, divAlphabet, divModuleList,
sectionName,
+ nonEmptySectionName,
shortDeclList,
shortSubDecls,
@@ -66,6 +67,14 @@ sectionName :: Html -> Html
sectionName = paragraph ! [theclass "caption"]
+-- | Make an element that always has at least something (a non-breaking space).
+-- If it would have otherwise been empty, then give it the class ".empty".
+nonEmptySectionName :: Html -> Html
+nonEmptySectionName c
+ | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
+ | otherwise = paragraph ! [theclass "caption"] $ c
+
+
divPackageHeader, divContent, divModuleHeader, divFooter,
divTableOfContents, divDescription, divSynposis, divInterface,
divIndex, divAlphabet, divModuleList
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 7c2375cf..2f2b82ed 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -14,6 +14,7 @@ module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinder',
ppModule, ppModuleRef,
+ ppIPName,
linkId
) where
@@ -24,11 +25,13 @@ import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.Map as M
import qualified Data.List as List
import GHC
import Name
import RdrName
+import FastString (unpackFS)
ppOccName :: OccName -> Html
@@ -38,6 +41,9 @@ ppOccName = toHtml . occNameString
ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc
+ppIPName :: HsIPName -> Html
+ppIPName = toHtml . unpackFS . hsIPNameFS
+
ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
@@ -52,7 +58,10 @@ ppDocName qual docName =
case docName of
Documented name mdl ->
linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
- Undocumented name -> ppQualifyName qual name (nameModule name)
+ Undocumented name
+ | isExternalName name || isWiredInName name ->
+ ppQualifyName qual name (nameModule name)
+ | otherwise -> ppName name
-- | Render a name depending on the selected qualification mode
@@ -61,28 +70,33 @@ ppQualifyName qual name mdl =
case qual of
NoQual -> ppName name
FullQual -> ppFullQualName mdl name
- -- this is just in case, it should never happen
- LocalQual Nothing -> ppQualifyName FullQual name mdl
- LocalQual (Just localmdl)
- | moduleString mdl == moduleString localmdl -> ppName name
- | otherwise -> ppFullQualName mdl name
- -- again, this never happens
- RelativeQual Nothing -> ppQualifyName FullQual name mdl
- RelativeQual (Just localmdl) ->
+ LocalQual localmdl ->
+ if moduleString mdl == moduleString localmdl
+ then ppName name
+ else ppFullQualName mdl name
+ RelativeQual localmdl ->
case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
- Just [] -> ppQualifyName NoQual name mdl
+ Just [] -> ppName name
-- sub-module, A.B.x -> B.x
Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
-- some module with same prefix, ABC.x -> ABC.x
- Just _ -> ppQualifyName FullQual name mdl
+ Just _ -> ppFullQualName mdl name
-- some other module, D.x -> D.x
- Nothing -> ppQualifyName FullQual name mdl
+ Nothing -> ppFullQualName mdl name
+ AliasedQual aliases localmdl ->
+ case (moduleString mdl == moduleString localmdl,
+ M.lookup mdl aliases) of
+ (False, Just alias) -> ppQualName alias name
+ _ -> ppName name
ppFullQualName :: Module -> Name -> Html
ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
+ppQualName :: ModuleName -> Name -> Html
+ppQualName mdlName name =
+ toHtml $ moduleNameString mdlName ++ '.' : getOccString name
ppName :: Name -> Html
ppName name = toHtml (getOccString name)
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
index 7ba6d5f4..be1fcb9b 100644
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Utils (
spliceURL,
groupId,
- (<+>), char, nonEmpty,
+ (<+>), char,
keyword, punctuate,
braces, brackets, pabrackets, parens, parenList, ubxParenList,
@@ -44,7 +44,7 @@ import Name ( getOccString, nameOccName, isValOcc )
spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
+spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
where
file = fromMaybe "" maybe_file
mdl = case maybe_mod of
@@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url
run ('%':'N':rest) = name ++ run rest
run ('%':'K':rest) = kind ++ run rest
run ('%':'L':rest) = line ++ run rest
- run ('%':'%':rest) = "%" ++ run rest
+ run ('%':'%':rest) = '%' : run rest
run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
@@ -119,15 +119,6 @@ char :: Char -> Html
char c = toHtml [c]
--- | Make an element that always has at least something (a non-breaking space)
--- If it would have otherwise been empty, then give it the class ".empty"
-nonEmpty :: (Html -> Html) -> Html -> Html
-nonEmpty el content_ =
- if isNoHtml content_
- then el ! [theclass "empty"] << spaceHtml
- else el << content_
-
-
quote :: Html -> Html
quote h = char '`' +++ h +++ '`'
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 82b57f0c..7c9a2ee5 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,6 +20,7 @@ module Haddock.Convert where
import HsSyn
import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
import TypeRep
+import Type(isStrLitTy)
import Kind ( splitKindFunTys, synTyConResKind )
import Name
import Var
@@ -29,8 +30,10 @@ import DataCon
import BasicTypes ( TupleSort(..) )
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon )
+import PrelNames (ipClassName)
import Bag ( emptyBag )
import SrcLoc ( Located, noLoc, unLoc )
+import Data.List( partition )
-- the main function here! yay!
@@ -51,77 +54,78 @@ tyThingToLHsDecl t = noLoc $ case t of
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
+ { tcdCtxt = synifyCtx (classSCTheta cl)
+ , tcdLName = synifyName cl
+ , tcdTyVars = synifyTyVars (classTyVars cl)
+ , tcdFDs = map (\ (l,r) -> noLoc
+ (map getName l, map getName r) ) $
+ snd $ classTvsFds cl
+ , tcdSigs = map (noLoc . synifyIdSig DeleteTopLevelQuantification)
+ (classMethods cl)
+ , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
- [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]
- [] --ignore associated type defaults
- [] --we don't have any docs at this point
+ , tcdATs = [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]
+ , tcdATDefs = [] --ignore associated type defaults
+ , tcdDocs = [] --we don't have any docs at this point
+ , tcdFVs = placeHolderNames }
| 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.)
- ACoAxiom ax -> TyClD (synifyAxiom ax)
+ ACoAxiom ax -> InstD (FamInstD { lid_inst = synifyAxiom ax })
-- a data-constructor alone just gets rendered as a function:
ADataCon dc -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
-synifyATDefault :: TyCon -> LTyClDecl Name
+synifyATDefault :: TyCon -> LFamInstDecl Name
synifyATDefault tc = noLoc (synifyAxiom ax)
where Just ax = tyConFamilyCoercion_maybe tc
-synifyAxiom :: CoAxiom -> TyClDecl Name
+synifyAxiom :: CoAxiom -> FamInstDecl Name
synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
| Just (tc, args) <- tcSplitTyConApp_maybe lhs
= let name = synifyName tc
- tyvars = synifyTyVars tvs
typats = map (synifyType WithinType) args
hs_rhs_ty = synifyType WithinType rhs
- in TySynonym name tyvars (Just typats) hs_rhs_ty
+ in FamInstDecl { fid_tycon = name
+ , fid_pats = HsWB { hswb_cts = typats, hswb_kvs = [], hswb_tvs = map tyVarName tvs }
+ , fid_defn = TySynonym hs_rhs_ty, fid_fvs = placeHolderNames }
| otherwise
= error "synifyAxiom"
synifyTyCon :: TyCon -> TyClDecl Name
synifyTyCon tc
- | isFunTyCon tc || isPrimTyCon tc =
- TyData
- -- arbitrary lie, they are neither algebraic data nor newtype:
- DataType
- -- no built-in type has any stupidTheta:
- (noLoc [])
- (synifyName tc)
- -- tyConTyVars doesn't work on fun/prim, but we can make them up:
- (zipWith
- (\fakeTyVar realKind -> noLoc $
- 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 (synifyKind (tyConKind tc)))
- -- no algebraic constructors:
- []
- -- "deriving" needn't be specified:
- Nothing
- | isSynFamilyTyCon tc =
- case synTyConRhs tc of
+ | isFunTyCon tc || isPrimTyCon tc
+ = TyDecl { tcdLName = synifyName tc
+ , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+ let mk_hs_tv realKind fakeTyVar
+ = noLoc $ KindedTyVar (getName fakeTyVar)
+ (synifyKindSig realKind)
+ in HsQTvs { hsq_kvs = [] -- No kind polymorhism
+ , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
+ alphaTyVars --a, b, c... which are unfortunately all kind *
+ }
+
+ , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither
+ -- algebraic data nor newtype:
+ , td_ctxt = noLoc []
+ , td_cType = Nothing
+ , td_kindSig = Just (synifyKindSig (tyConKind tc))
+ -- we have their kind accurately:
+ , td_cons = [] -- No constructors
+ , td_derivs = Nothing }
+ , tcdFVs = placeHolderNames }
+ | isSynFamilyTyCon tc
+ = case synTyConRhs tc of
SynFamilyTyCon ->
TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind
+ (Just (synifyKindSig (synTyConResKind tc)))
_ -> error "synifyTyCon: impossible open type synonym?"
- | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)
- case algTyConRhs tc of
+ | isDataFamilyTyCon tc
+ = --(why no "isOpenAlgTyCon"?)
+ case algTyConRhs tc of
DataFamilyTyCon ->
TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
Nothing --always kind '*'
@@ -137,9 +141,6 @@ synifyTyCon tc
alg_ctx = synifyCtx (tyConStupidTheta tc)
name = synifyName tc
tyvars = synifyTyVars (tyConTyVars tc)
- typats = case tyConFamInst_maybe tc of
- Nothing -> Nothing
- Just (_, indexes) -> Just (map (synifyType WithinType) indexes)
alg_kindSig = Just (tyConKind tc)
-- The data constructors.
--
@@ -162,10 +163,14 @@ synifyTyCon tc
-- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = Nothing
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 (fmap synifyKind alg_kindSig) alg_cons alg_deriv
-
+ defn | isSynTyCon tc = TySynonym syn_type
+ | otherwise = TyData { td_ND = alg_nd, td_ctxt = alg_ctx
+ , td_cType = Nothing
+ , td_kindSig = fmap synifyKindSig alg_kindSig
+ , td_cons = alg_cons
+ , td_derivs = alg_deriv }
+ in TyDecl { tcdLName = name, tcdTyVars = tyvars, tcdTyDefn = defn
+ , tcdFVs = placeHolderNames }
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -230,16 +235,17 @@ synifyCtx :: [PredType] -> LHsContext Name
synifyCtx = noLoc . map (synifyType WithinType)
-synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
-synifyTyVars = map synifyTyVar
+synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
+ , hsq_tvs = map synifyTyVar tvs }
where
- synifyTyVar tv = noLoc $ let
- kind = tyVarKind tv
- name = getName tv
- in if isLiftedTypeKind kind
- then UserTyVar name placeHolderKind
- else KindedTyVar name (synifyKind kind) placeHolderKind
-
+ (kvs, tvs) = partition isKindVar ktvs
+ synifyTyVar tv
+ | isLiftedTypeKind kind = noLoc (UserTyVar name)
+ | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))
+ where
+ kind = tyVarKind tv
+ name = getName tv
--states of what to do with foralls:
data SynifyTypeState
@@ -271,9 +277,10 @@ synifyType _ (TyConApp tc tys)
| 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)
+ | tyConName tc == ipClassName
+ , [name, ty] <- tys
+ , Just x <- isStrLitTy name
+ = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
-- and equalities
| tc == eqTyCon
, [ty1, ty2] <- tys
@@ -305,9 +312,14 @@ synifyType s forallty@(ForAllTy _tv _ty) =
sTau = synifyType WithinType tau
in noLoc $
HsForAllTy forallPlicitness sTvs sCtx sTau
+synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+
+synifyTyLit :: TyLit -> HsTyLit
+synifyTyLit (NumTyLit n) = HsNumTy n
+synifyTyLit (StrTyLit s) = HsStrTy s
-synifyKind :: Kind -> LHsKind Name
-synifyKind = synifyType (error "synifyKind")
+synifyKindSig :: Kind -> LHsKind Name
+synifyKindSig k = synifyType (error "synifyKind") k
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
([HsType Name], Name, [HsType Name])
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index fc04351b..a841e567 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -78,7 +78,7 @@ isVarSym = isLexVarSym . occNameFS
getMainDeclBinder :: HsDecl name -> [name]
-getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d]
+getMainDeclBinder (TyClD d) = [tcdName d]
getMainDeclBinder (ValD d) =
case collectHsBindBinders d of
[] -> []
@@ -138,7 +138,6 @@ isDocD _ = False
isInstD :: HsDecl a -> Bool
isInstD (InstD _) = True
-isInstD (TyClD d) = isFamInstDecl d
isInstD _ = False
@@ -152,12 +151,12 @@ declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d
declATs _ = []
-pretty :: Outputable a => a -> String
-pretty x = showSDoc (ppr x)
+pretty :: Outputable a => DynFlags -> a -> String
+pretty = showPpr
-trace_ppr :: Outputable a => a -> b -> b
-trace_ppr x y = trace (pretty x) y
+trace_ppr :: Outputable a => DynFlags -> a -> b -> b
+trace_ppr dflags x y = trace (pretty dflags x) y
-------------------------------------------------------------------------------
@@ -216,7 +215,7 @@ instance Parent (ConDecl Name) where
instance Parent (TyClDecl Name) where
children d
- | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d
+ | isDataDecl d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d
| isClassDecl d =
map (tcdName . unL) (tcdATs d) ++
[ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
@@ -232,7 +231,7 @@ family = getName &&& children
-- child to its grand-children, recursively.
families :: TyClDecl Name -> [(Name, [Name])]
families d
- | isDataDecl d = family d : map (family . unL) (tcdCons d)
+ | isDataDecl d = family d : map (family . unL) (td_cons (tcdTyDefn d))
| isClassDecl d = family d : concatMap (families . unL) (tcdATs d)
| otherwise = []
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
index 0003cba2..5a8e8485 100644
--- a/src/Haddock/Interface.hs
+++ b/src/Haddock/Interface.hs
@@ -50,6 +50,7 @@ import System.FilePath
import Text.Printf
import Digraph
+import DynFlags hiding (verbosity, flags)
import Exception
import GHC hiding (verbosity, flags)
import HscTypes
@@ -88,8 +89,9 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Renaming interfaces..."
let warnings = Flag_NoWarnings `notElem` flags
+ dflags <- getDynFlags
let (interfaces'', msgs) =
- runWriter $ mapM (renameInterface links warnings) interfaces'
+ runWriter $ mapM (renameInterface dflags links warnings) interfaces'
liftIO $ mapM_ putStrLn msgs
return (interfaces'', homeLinks)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 089f31b4..8fff4d7a 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP, MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -96,7 +96,7 @@ lookupInstDoc name iface ifaceMap instIfaceMap =
-- | Like GHC's getInfo but doesn't cut things out depending on the
-- interative context, which we don't set sufficiently anyway.
-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst]))
getAllInfo name = withSession $ \hsc_env -> do
(_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
return r
@@ -111,7 +111,9 @@ getAllInfo name = withSession $ \hsc_env -> do
-- in Haddock output) and unifying special tycons with normal ones.
-- For the benefit of the user (looks nice and predictable) and the
-- tests (which prefer output to be deterministic).
-data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
+data SimpleType = SimpleType Name [SimpleType]
+ | SimpleTyLit TyLit
+ deriving (Eq,Ord)
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
@@ -131,6 +133,7 @@ instHead (_, _, cls, args)
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+ simplify (LitTy l) = SimpleTyLit l
-- sortImage f = sortBy (\x y -> compare (f x) (f y))
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 2bca57d0..32f287f5 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections, BangPatterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Create
@@ -27,14 +28,20 @@ import Data.Maybe
import Data.Monoid
import Data.Ord
import Control.Applicative
+import Control.DeepSeq
import Control.Monad
-import qualified Data.Traversable as Traversable
+import qualified Data.Traversable as T
+import qualified Packages
+import qualified Module
+import qualified SrcLoc
import GHC hiding (flags)
import HscTypes
import Name
import Bag
-import RdrName (GlobalRdrEnv)
+import RdrName
+import TcRnTypes
+import FastString (unpackFS)
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -43,12 +50,15 @@ import RdrName (GlobalRdrEnv)
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
+ let ms = pm_mod_summary . tm_parsed_module $ tm
+ mi = moduleInfo tm
+ !safety = modInfoSafe mi
+ mdl = ms_mod ms
+ dflags = ms_hspp_opts ms
+ !instances = modInfoInstances mi
+ !exportedNames = modInfoExports mi
+
+ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
@@ -59,56 +69,55 @@ createInterface tm flags modMap instIfaceMap = do
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)
-
opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader
+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl . getName) instances
- maps@(docMap, argMap, subMap, declMap) <-
- liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs
+ maps@(!docMap, !argMap, !subMap, !declMap) <-
+ liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs
let exports0 = fmap (reverse . map unLoc) mayExports
exports
| OptIgnoreExports `elem` opts = Nothing
| otherwise = exports0
- liftErrMsg $ warnAboutFilteredDecls mdl decls
+ liftErrMsg $ warnAboutFilteredDecls dflags mdl decls
- exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports
+ let warningMap = mkWarningMap warnings gre exportedNames
+ exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports
instances instIfaceMap dflags
- let visibleNames = mkVisibleNames exportItems opts
+ let !visibleNames = mkVisibleNames exportItems opts
-- 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)
+ 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
-- documentation, if the 'prune' option is on.
- let
- prunedExportItems
- | OptPrune `elem` opts = prunedExportItems0
- | otherwise = exportItems
+ let prunedExportItems'
+ | OptPrune `elem` opts = prunedExportItems0
+ | otherwise = exportItems
+ !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
- return Interface {
+ let !aliases =
+ mkAliasMap dflags $ tm_renamed_source tm
+
+ return $! Interface {
ifaceMod = mdl,
ifaceOrigFilename = msHsFilePath ms,
ifaceInfo = info,
- ifaceDoc = mbDoc,
- ifaceRnDoc = Nothing,
+ ifaceDoc = Documentation mbDoc (moduleWarning warnings),
+ ifaceRnDoc = Documentation Nothing Nothing,
ifaceOptions = opts,
ifaceDocMap = docMap,
ifaceArgMap = argMap,
@@ -120,10 +129,70 @@ createInterface tm flags modMap instIfaceMap = do
ifaceVisibleExports = visibleNames,
ifaceDeclMap = declMap,
ifaceSubMap = subMap,
+ ifaceModuleAliases = aliases,
ifaceInstances = instances,
ifaceHaddockCoverage = coverage
}
+mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap dflags mRenamedSource =
+ case mRenamedSource of
+ Nothing -> M.empty
+ Just (_,impDecls,_,_) ->
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ alias <- ideclAs impDecl
+ return $
+ (lookupModuleDyn dflags
+ (fmap Module.fsToPackageId $
+ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ alias))
+ impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+ DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+ Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+ flip Module.mkModule mdlName $
+ case filter snd $
+ Packages.lookupModuleInAllPackages dflags mdlName of
+ (pkgId,_):_ -> Packages.packageConfigId pkgId
+ [] -> Module.mainPackageId
+
+
+-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+type WarningMap = DocMap Name
+
+mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap NoWarnings _ _ = M.empty
+mkWarningMap (WarnAll _) _ _ = M.empty
+mkWarningMap (WarnSome ws) gre exps = M.fromList
+ [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+
+
+moduleWarning :: Warnings -> Maybe (Doc id)
+moduleWarning ws =
+ case ws of
+ NoWarnings -> Nothing
+ WarnSome _ -> Nothing
+ WarnAll w -> Just $! warnToDoc w
+
+
+warnToDoc :: WarningTxt -> Doc id
+warnToDoc w = case w of
+ (DeprecatedTxt msg) -> format "Deprecated: " msg
+ (WarningTxt msg) -> format "Warning: " msg
+ where
+ format x xs = let !str = force $ concat (x : map unpackFS xs)
+ in DocWarning $ DocParagraph $ DocString str
+
-------------------------------------------------------------------------------
-- Doc options
@@ -153,62 +222,71 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
--------------------------------------------------------------------------------
--- Declarations
+-- Maps
--------------------------------------------------------------------------------
type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap)
-
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
mkMaps :: DynFlags
-> GlobalRdrEnv
- -> [Instance]
- -> [Name]
+ -> [ClsInst]
-> [(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)
+mkMaps dflags gre instances decls = do
+ (a, b, c, d) <- unzip4 <$> mapM mappings decls
+ return (f a, f b, f c, f d)
where
- 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
-
- let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ]
-
- (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)))
-
- 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)
-
+ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f = M.fromListWith (<>) . concat
+
+ mappings (ldecl, docStrs) = do
+ let decl = unLoc ldecl
+ let declDoc strs m = do
+ doc <- processDocStrings dflags gre strs
+ m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m
+ return (doc, m')
+ (doc, args) <- declDoc docStrs (typeDocs decl)
+ let subs = subordinates decl
+ (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs
+ let ns = names decl
+ subNs = [ n | (n, _, _) <- subs ]
+ dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+ sm = [ (n, subNs) | n <- ns ]
+ cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
+ seqList ns `seq`
+ seqList subNs `seq`
+ doc `seq`
+ seqList subDocs `seq`
+ seqList subArgs `seq`
+ return (dm, am, sm, cm)
+
+ instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ]
+ names :: HsDecl Name -> [Name]
+ names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2].
+ names decl = getMainDeclBinder decl
-- Note [2]:
------------
--- We relate Instances to InstDecls using the SrcSpans buried inside them.
+-- We relate ClsInsts 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
+-- This lets us relate Names (from ClsInsts) to comments (associated
-- with InstDecls).
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates (TyClD decl)
| isClassDecl decl = classSubs
@@ -219,7 +297,7 @@ subordinates (TyClD decl)
]
dataSubs = constrs ++ fields
where
- cons = map unL $ tcdCons decl
+ cons = map unL $ (td_cons (tcdTyDefn decl))
constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
| c <- cons ]
fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
@@ -235,7 +313,7 @@ typeDocs d =
case d of
SigD (TypeSig _ ty) -> docs (unLoc ty)
ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
- TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty)
+ TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty)
_ -> M.empty
where
go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
@@ -293,26 +371,26 @@ sortByLoc :: [Located a] -> [Located a]
sortByLoc = sortBy (comparing getLoc)
-warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM ()
-warnAboutFilteredDecls mdl decls = do
+warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM ()
+warnAboutFilteredDecls dflags mdl decls = do
let modStr = moduleString mdl
let typeInstances =
- nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ]
+ nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ]
unless (null typeInstances) $
tell [
"Warning: " ++ modStr ++ ": Instances of type and data "
++ "families are not yet supported. Instances of the following families "
- ++ "will be filtered out:\n " ++ concat (intersperse ", "
+ ++ "will be filtered out:\n " ++ (intercalate ", "
$ map (occNameString . nameOccName) typeInstances) ]
- let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls
+ let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls
, not (null ats) ]
unless (null instances) $
tell [
"Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "
- ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ]
+ ++ "These instances are affected:\n" ++ intercalate ", " instances ]
--------------------------------------------------------------------------------
@@ -324,7 +402,7 @@ warnAboutFilteredDecls mdl decls = do
-- | Filter out declarations that we don't handle in Haddock
filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls decls = filter (isHandled . unL . fst) decls
+filterDecls = filter (isHandled . unL . fst)
where
isHandled (ForD (ForeignImport {})) = True
isHandled (TyClD {}) = True
@@ -361,10 +439,10 @@ collectDocs = go Nothing []
where
go Nothing _ [] = []
go (Just prev) docs [] = finished prev docs []
- go prev docs ((L _ (DocD (DocCommentNext str))):ds)
+ 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 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)
@@ -380,49 +458,42 @@ collectDocs = go Nothing []
mkExportItems
:: IfaceMap
-> Module -- this module
+ -> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
-> [LHsDecl Name]
-> Maps
-> Maybe [IE Name]
- -> [Instance]
+ -> [ClsInst]
-> InstIfaceMap
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod gre exportedNames decls0
+ modMap thisMod warnings gre exportedNames decls0
(maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags =
case optExports of
- Nothing -> fullModuleContents dflags gre maps decls
- Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
+ Nothing -> fullModuleContents dflags warnings gre maps decls
+ Just exports -> liftM 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
- -- situations and remove the duplicates.
- commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) =
- getMainDeclBinder sig1 == getMainDeclBinder sig2
- commaDeclared _ _ = False
-
lookupExport (IEVar x) = declWith x
lookupExport (IEThingAbs t) = declWith t
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps
lookupExport (IEGroup lev docStr) = liftErrMsg $
- ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
+ ifDoc (processDocString dflags gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
lookupExport (IEDoc docStr) = liftErrMsg $
- ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+ ifDoc (processDocStringParas dflags gre docStr)
(\doc -> return [ ExportDoc doc ])
lookupExport (IEDocNamed str) = liftErrMsg $
ifDoc (findNamedDoc str [ unL d | d <- decls ])
(\docStr ->
- ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
+ ifDoc (processDocStringParas dflags gre docStr)
(\doc -> return [ ExportDoc doc ]))
@@ -437,7 +508,7 @@ mkExportItems
case findDecl t of
([L _ (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
- export <- hiValExportItem t doc
+ export <- hiValExportItem dflags t doc
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
@@ -450,12 +521,12 @@ mkExportItems
-- We should not show a subordinate by itself if any of its
-- parents is also exported. See note [1].
- | not $ t `elem` declNames,
+ | t `notElem` declNames,
Just p <- find isExported (parents t $ unL decl) ->
do liftErrMsg $ tell [
"Warning: " ++ moduleString thisMod ++ ": " ++
- pretty (nameOccName t) ++ " is exported separately but " ++
- "will be documented under " ++ pretty (nameOccName p) ++
+ pretty dflags (nameOccName t) ++ " is exported separately but " ++
+ "will be documented under " ++ pretty dflags (nameOccName p) ++
". Consider exporting it together with its parent(s)" ++
" for code clarity." ]
return []
@@ -463,33 +534,32 @@ mkExportItems
-- normal case
| 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
- -- requires modifying the type signatures to "hide" the
- -- names that are not exported.
+ -- A single signature might refer to many names, but we
+ -- create an export item for a single name only. So we
+ -- modify the signature to contain only that single name.
newDecl = case decl of
(L loc (SigD sig)) ->
- L loc . SigD . fromJust $ filterSigNames isExported sig
+ L loc . SigD . fromJust $ filterSigNames (== t) sig
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
_ -> decl
-- Declaration from another package
([], _) -> do
- mayDecl <- hiDecl t
+ mayDecl <- hiDecl dflags t
case mayDecl of
Nothing -> return [ ExportNoDecl t [] ]
- Just decl -> do
+ Just decl ->
-- 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]
+ ["Warning: Couldn't find .haddock for export " ++ pretty dflags 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)) ]
+ Just iface ->
+ return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
@@ -509,39 +579,42 @@ mkExportItems
findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
| m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n docMap argMap subMap)
+ (ds, lookupDocs n warnings 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))
+ (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
| otherwise = ([], (noDocForDecl, []))
where
m = nameModule n
-hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
-hiDecl t = do
+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl dflags t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
case mayTyThing of
Nothing -> do
- liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t]
+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
return Nothing
Just x -> return (Just (tyThingToLHsDecl x))
-hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
-hiValExportItem name doc = do
- mayDecl <- hiDecl name
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc = do
+ mayDecl <- hiDecl dflags 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)
+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings docMap argMap subMap =
+ let lookupArgDoc x = M.findWithDefault M.empty x argMap in
+ let doc = (lookupDoc n, lookupArgDoc n) in
+ let subs = M.findWithDefault [] n subMap in
+ let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
+ (doc, subDocs)
+ where
+ lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
-- | Return all export items produced by an exported module. That is, we're
@@ -560,6 +633,7 @@ lookupDocs name docMap argMap subMap =
moduleExports :: Module -- ^ Module A
-> ModuleName -- ^ The real name of B, the exported module
-> DynFlags -- ^ The flags used when typechecking A
+ -> WarningMap
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
-> [LHsDecl Name] -- ^ All the declarations in A
@@ -567,8 +641,8 @@ moduleExports :: Module -- ^ Module A
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps
- | m == thisMod = fullModuleContents dflags gre maps decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps
+ | m == thisMod = fullModuleContents dflags warnings gre maps decls
| otherwise =
case M.lookup m ifaceMap of
Just iface
@@ -581,8 +655,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
Just iface -> return [ ExportModule (instMod iface) ]
Nothing -> do
liftErrMsg $
- tell ["Warning: " ++ pretty thisMod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty expMod]
+ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags expMod]
return []
where
m = mkModule packageId expMod
@@ -606,25 +680,39 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls =
- liftM catMaybes $ mapM mkExportItem decls
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
+ liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
+ -- A type signature can have multiple names, like:
+ -- foo, bar :: Types..
+ --
+ -- We go through the list of declarations and expand type signatures, so
+ -- that every type signature has exactly one name!
+ expandSig :: [LHsDecl name] -> [LHsDecl name]
+ expandSig = foldr f []
+ where
+ f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f x xs = x : xs
+
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
+ mbDoc <- liftErrMsg $ processDocString dflags gre docStr
return $ fmap (ExportGroup lev "") mbDoc
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+ mbDoc <- liftErrMsg $ processDocStringParas dflags 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)
+ let (doc, _) = lookupDocs name warnings docMap argMap subMap in
+ fmap Just (hiValExportItem dflags name doc)
| otherwise = return Nothing
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
- let (doc, subs) = lookupDocs name docMap argMap subMap in
+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
return $ Just (ExportDecl decl doc subs [])
| otherwise = return Nothing
@@ -648,7 +736,7 @@ extractDecl name mdl decl
_ -> error "internal: extractDecl"
TyClD d | isDataDecl d ->
let (n, tyvar_names) = name_and_tyvars d
- L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)
+ L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d))
in L pos (SigD sig)
_ -> error "internal: extractDecl"
where
@@ -663,7 +751,7 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
L _ (HsForAllTy expl tvs (L _ preds) ty) ->
L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
- _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))
where
lctxt = noLoc . ctxt
ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
@@ -684,18 +772,19 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)
--- Pruning
+-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems items = filter hasDoc items
+pruneExportItems = filter hasDoc
where
- hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d
+ hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]
mkVisibleNames exports opts
| OptHide `elem` opts = []
- | otherwise = concatMap exportName exports
+ | otherwise = let ns = concatMap exportName exports
+ in seqList ns `seq` ns
where
exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs
where subs = map fst (expItemSubDocs e)
@@ -703,15 +792,18 @@ mkVisibleNames exports opts
-- we don't want links to go to them.
exportName _ = []
+seqList :: [a] -> ()
+seqList [] = ()
+seqList (x : xs) = x `seq` seqList xs
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
-findNamedDoc name decls = search decls
+findNamedDoc name = search
where
search [] = do
tell ["Cannot find documentation for: $" ++ name]
return Nothing
- search ((DocD (DocCommentNamed name' doc)):rest)
+ search (DocD (DocCommentNamed name' doc) : rest)
| name == name' = return (Just doc)
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index f70c5953..3ad9719e 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -1,4 +1,6 @@
------------------------------------------------------------------------------
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE BangPatterns #-}
+ -----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
-- Copyright : (c) Isaac Dupree 2009,
@@ -9,11 +11,10 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
- ( HaddockCommentType(..)
- , lexParseRnHaddockComment
- , lexParseRnHaddockCommentList
- , lexParseRnMbHaddockComment
- , lexParseRnHaddockModHeader
+ ( processDocString
+ , processDocStringParas
+ , processDocStrings
+ , processModuleHeader
) where
@@ -24,6 +25,7 @@ import Haddock.Interface.ParseModuleHeader
import Haddock.Doc
import Control.Applicative
+import Data.List
import Data.Maybe
import FastString
import GHC
@@ -33,64 +35,62 @@ 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
- let docs = catMaybes docMbs
- let doc = foldl docAppend DocEmpty docs
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
+processDocStrings dflags gre strs = do
+ docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
+ let doc = foldl' docAppend DocEmpty docs
case doc of
DocEmpty -> return Nothing
_ -> return (Just doc)
-lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
- GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
-lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
+processDocString = process parseString
+
+process :: ([LToken] -> Maybe (Doc RdrName))
+ -> DynFlags
+ -> GlobalRdrEnv
+ -> HsDocString
+ -> ErrMsgM (Maybe (Doc Name))
+process parse dflags gre (HsDocString fs) = do
let str = unpackFS fs
- let toks = tokenise dflags str (0,0) -- TODO: real position
- let parse = case hty of
- NormalHaddockComment -> parseParas
- DocSectionComment -> parseString
+ let toks = tokenise dflags str (0,0) -- TODO: real position
case parse toks of
Nothing -> do
- tell ["doc comment parse failed: "++str]
+ tell [ "doc comment parse failed: " ++ str ]
return Nothing
- Just doc -> return (Just (rename gre doc))
-
+ Just doc -> return (Just (rename dflags 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
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+ -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre safety mayStr = do
+ (hmi, doc) <-
+ case mayStr of
--- 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
- (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]
+ Left msg -> do
+ tell ["haddock module header parse failed: " ++ msg]
return failure
- Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))
- return (hmi { hmi_safety = safety }, docn)
+ Right (hmi, doc) -> do
+ let !descr = rename dflags gre <$> hmi_description hmi
+ hmi' = hmi { hmi_description = descr }
+ doc' = rename dflags gre doc
+ return (hmi', Just doc')
+ return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc)
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
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename dflags gre = rn
where
rn d = case d of
DocAppend a b -> DocAppend (rn a) (rn b)
@@ -101,13 +101,15 @@ rename gre = rn
case names of
[] ->
case choices of
- [] -> DocMonospaced (DocString (showSDoc $ ppr x))
- [a] -> outOfScope a
- a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b
+ [] -> DocMonospaced (DocString (showPpr dflags x))
+ [a] -> outOfScope dflags a
+ a:b:_ | isRdrTc a -> outOfScope dflags a
+ | otherwise -> outOfScope dflags 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.
+ DocWarning doc -> DocWarning (rn doc)
DocEmphasis doc -> DocEmphasis (rn doc)
DocMonospaced doc -> DocMonospaced (rn doc)
DocUnorderedList docs -> DocUnorderedList (map rn docs)
@@ -116,7 +118,7 @@ rename gre = rn
DocCodeBlock doc -> DocCodeBlock (rn doc)
DocIdentifierUnchecked x -> DocIdentifierUnchecked x
DocModule str -> DocModule str
- DocURL str -> DocURL str
+ DocHyperlink l -> DocHyperlink l
DocPic str -> DocPic str
DocAName str -> DocAName str
DocExamples e -> DocExamples e
@@ -124,12 +126,12 @@ rename gre = rn
DocString str -> DocString str
-outOfScope :: RdrName -> Doc a
-outOfScope x =
+outOfScope :: DynFlags -> RdrName -> Doc a
+outOfScope dflags 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))
+ monospaced a = DocMonospaced (DocString (showPpr dflags a))
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
index 35533d0d..18f4c768 100644
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.ParseModuleHeader
@@ -137,14 +138,14 @@ parseKey key toParse0 =
(spaces1,cs1) = extractLeadingSpaces cs
in
(c:spaces1,cs1)
- | True = ([],s)
+ | otherwise = ([],s)
extractNextLine :: String -> (String,String)
extractNextLine [] = ([],[])
extractNextLine (c:cs)
| c == '\n' =
([],cs)
- | True =
+ | otherwise =
let
(line,rest) = extractNextLine cs
in
@@ -156,5 +157,5 @@ parseKey key toParse0 =
extractPrefix _ [] = Nothing
extractPrefix (c1:cs1) (c2:cs2)
| toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
- | True = Nothing
+ | otherwise = Nothing
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 691dafbc..0f702683 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -12,23 +12,23 @@
module Haddock.Interface.Rename (renameInterface) where
-import Haddock.Types
import Haddock.GhcUtils
+import Haddock.Types
+import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
-import Bag (emptyBag)
-import BasicTypes ( IPName(..), ipNameName )
+import Control.Applicative
+import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
-import Prelude hiding (mapM)
import Data.Traversable (mapM)
-import Control.Monad hiding (mapM)
+import Prelude hiding (mapM)
-renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface renamingEnv warnings iface =
+renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface dflags renamingEnv warnings iface =
-- first create the local env, where every name exported by this module
-- is mapped to itself, and everything else comes from the global renaming
@@ -46,7 +46,7 @@ renameInterface renamingEnv warnings iface =
(rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
(finalModuleDoc, missingNames4)
- = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface))
+ = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
-- combine the missing names and filter out the built-ins, which would
-- otherwise allways be missing.
@@ -57,7 +57,7 @@ renameInterface renamingEnv warnings iface =
-- representation. TODO: use the Name constants from the GHC API.
-- strings = filter (`notElem` ["()", "[]", "(->)"])
-- (map pretty missingNames)
- strings = map pretty . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
+ strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
in do
-- report things that we couldn't link to. Only do this for non-hidden
@@ -93,6 +93,13 @@ instance Monad (GenRnM n) where
(>>=) = thenRn
return = returnRn
+instance Functor (GenRnM n) where
+ fmap f x = do a <- x; return (f a)
+
+instance Applicative (GenRnM n) where
+ pure = return
+ (<*>) = ap
+
returnRn :: a -> GenRnM n a
returnRn a = RnM (const (a,[]))
thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
@@ -138,15 +145,14 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
renameExportItems = mapM renameExportItem
-renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName)
-renameDocForDecl (mbDoc, fnArgsDoc) = do
- mbDoc' <- renameMaybeDoc mbDoc
- fnArgsDoc' <- renameFnArgsDoc fnArgsDoc
- return (mbDoc', fnArgsDoc')
+renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
+renameDocForDecl (doc, fnArgsDoc) =
+ (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
-renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName))
-renameMaybeDoc = mapM renameDoc
+renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
+renameDocumentation (Documentation mDoc mWarning) =
+ Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
@@ -169,6 +175,9 @@ renameDoc d = case d of
return (DocIdentifier x')
DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
DocModule str -> return (DocModule str)
+ DocWarning doc -> do
+ doc' <- renameDoc doc
+ return (DocWarning doc')
DocEmphasis doc -> do
doc' <- renameDoc doc
return (DocEmphasis doc')
@@ -190,7 +199,7 @@ renameDoc d = case d of
DocCodeBlock doc -> do
doc' <- renameDoc doc
return (DocCodeBlock doc')
- DocURL str -> return (DocURL str)
+ DocHyperlink l -> return (DocHyperlink l)
DocPic str -> return (DocPic str)
DocAName str -> return (DocAName str)
DocExamples e -> return (DocExamples e)
@@ -206,14 +215,17 @@ renameLType = mapM renameType
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
-renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind :: Maybe (LHsKind Name)
+ -> RnM (Maybe (LHsKind DocName))
renameMaybeLKind Nothing = return Nothing
-renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just
+renameMaybeLKind (Just ki)
+ = do { ki' <- renameLKind ki
+ ; return (Just ki') }
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
HsForAllTy expl tyvars lcontext ltype -> do
- tyvars' <- mapM renameLTyVarBndr tyvars
+ tyvars' <- renameLTyVarBndrs tyvars
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsForAllTy expl tyvars' lcontext' ltype')
@@ -233,16 +245,16 @@ renameType t = case t of
HsListTy ty -> return . HsListTy =<< renameLType ty
HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
- HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)
+ HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsOpTy a (w, (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' (w, (L loc op')) b')
+ return (HsOpTy a' (w, L loc op') b')
HsParTy ty -> return . HsParTy =<< renameLType ty
@@ -256,15 +268,25 @@ renameType t = case t of
doc' <- renameLDocHsSyn doc
return (HsDocTy ty' doc')
+ HsTyLit x -> return (HsTyLit x)
+
_ -> error "renameType"
-renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
-renameLTyVarBndr (L loc tv) = do
- name' <- rename (hsTyVarName tv)
- tyvar' <- replaceTyVarName tv name' renameLKind
- return $ L loc tyvar'
+renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+ = do { tvs' <- mapM renameLTyVarBndr tvs
+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+ -- This is rather bogus, but I'm not sure what else to do
+renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
+renameLTyVarBndr (L loc (UserTyVar n))
+ = do { n' <- rename n
+ ; return (L loc (UserTyVar n')) }
+renameLTyVarBndr (L loc (KindedTyVar n k))
+ = do { n' <- rename n
+ ; k' <- renameLKind k
+ ; return (L loc (KindedTyVar n' k')) }
renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
renameLContext (L loc context) = do
@@ -314,54 +336,67 @@ renameTyClD d = case d of
-- TyFamily flav lname ltyvars kind tckind -> do
TyFamily flav lname ltyvars tckind -> do
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltyvars' <- renameLTyVarBndrs ltyvars
-- 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
+ TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do
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)
+ tyvars' <- renameLTyVarBndrs tyvars
+ defn' <- renameTyDefn defn
+ return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs })
- TySynonym lname ltyvars typats ltype -> do
- lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
- ltype' <- renameLType ltype
- typats' <- mapM (mapM renameLType) typats
- return (TySynonym lname' ltyvars' typats' ltype')
-
- ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do
+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltyvars' <- renameLTyVarBndrs ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM renameLTyClD ats
- at_defs' <- mapM renameLTyClD at_defs
+ at_defs' <- mapM (mapM renameFamInstD) at_defs
-- we don't need the default methods or the already collected doc entities
- return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' [])
+ return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
+ , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
where
- renameLCon (L loc con) = return . L loc =<< renameCon con
- renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
- , con_cxt = lcontext, con_details = details
- , con_res = restype, con_doc = mbldoc }) = do
+ renameLFunDep (L loc (xs, ys)) = do
+ xs' <- mapM rename xs
+ ys' <- mapM rename ys
+ return (L loc (xs', ys'))
+
+ renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName)
+renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType
+ , td_kindSig = k, td_cons = cons }) = do
+ lcontext' <- renameLContext lcontext
+ k' <- renameMaybeLKind k
+ cons' <- mapM (mapM renameCon) cons
+ -- I don't think we need the derivings, so we return Nothing
+ return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType
+ , td_kindSig = k', td_cons = cons', td_derivs = Nothing })
+
+renameTyDefn (TySynonym { td_synRhs = ltype }) = do
+ ltype' <- renameLType ltype
+ return (TySynonym { td_synRhs = ltype' })
+
+renameCon :: ConDecl Name -> RnM (ConDecl DocName)
+renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+ , con_cxt = lcontext, con_details = details
+ , con_res = restype, con_doc = mbldoc }) = do
lname' <- renameL lname
- ltyvars' <- mapM renameLTyVarBndr ltyvars
+ ltyvars' <- renameLTyVarBndrs ltyvars
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
-
+ where
renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields
renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
renameDetails (InfixCon a b) = do
@@ -378,14 +413,6 @@ renameTyClD d = case d of
renameResType (ResTyH98) = return ResTyH98
renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
- renameLFunDep (L loc (xs, ys)) = do
- xs' <- mapM rename xs
- ys' <- mapM rename ys
- return (L loc (xs', ys'))
-
- renameLSig (L loc sig) = return . L loc =<< renameSig sig
-
-
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
TypeSig lnames ltype -> do
@@ -408,10 +435,23 @@ renameForD (ForeignExport lname ltype co x) = do
renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
-renameInstD (InstDecl ltype _ _ lATs) = do
+renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do
ltype' <- renameLType ltype
- lATs' <- mapM renameLTyClD lATs
- return (InstDecl ltype' emptyBag [] lATs')
+ lATs' <- mapM (mapM renameFamInstD) lATs
+ return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
+ , cid_fam_insts = lATs' })
+
+renameInstD (FamInstD { lid_inst = d }) = do
+ d' <- renameFamInstD d
+ return (FamInstD { lid_inst = d' })
+
+renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName)
+renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; defn' <- renameTyDefn defn
+ ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' }
+ , fid_defn = defn', fid_fvs = placeHolderNames }) }
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index fcf7fe65..8fa8ce95 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
@@ -22,24 +22,25 @@ module Haddock.InterfaceFile (
import Haddock.Types
import Haddock.Utils hiding (out)
-import Data.List
-import Data.Word
+import Control.Monad
import Data.Array
import Data.IORef
+import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Word
-import GHC hiding (NoLink)
-import Binary
import BinIface (getSymtabName, getDictFastString)
-import Name
-import UniqSupply
-import UniqFM
-import IfaceEnv
-import HscTypes
-import GhcMonad (withSession)
+import Binary
import FastMutInt
import FastString
+import GHC hiding (NoLink)
+import GhcMonad (withSession)
+import HscTypes
+import IfaceEnv
+import Name
+import UniqFM
+import UniqSupply
import Unique
@@ -65,13 +66,15 @@ binaryInterfaceMagic = 0xD0Cface
-- we version our interface files accordingly.
binaryInterfaceVersion :: Word16
#if __GLASGOW_HASKELL__ == 702
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 21
#elif __GLASGOW_HASKELL__ == 703
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 21
#elif __GLASGOW_HASKELL__ == 704
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 21
#elif __GLASGOW_HASKELL__ == 705
-binaryInterfaceVersion = 19
+binaryInterfaceVersion = 21
+#elif __GLASGOW_HASKELL__ == 706
+binaryInterfaceVersion = 21
#else
#error Unknown GHC version
#endif
@@ -110,8 +113,8 @@ writeInterfaceFile filename iface = do
bin_dict_map = dict_map_ref }
-- put the main thing
- bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab)
- (putFastString bin_dict)
+ let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
+ (putFastString bin_dict)
put_ bh iface
-- write the symtab pointer at the front of the file
@@ -295,12 +298,9 @@ putSymbolTable bh next_off symtab = do
getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
getSymbolTable bh namecache = do
sz <- get bh
- od_names <- sequence (replicate sz (get bh))
- let
- arr = listArray (0,sz-1) names
- (namecache', names) =
- mapAccumR (fromOnDiskName arr) namecache od_names
- --
+ od_names <- replicateM sz (get bh)
+ let arr = listArray (0,sz-1) names
+ (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
return (namecache', arr)
@@ -415,6 +415,15 @@ instance Binary Example where
result <- get bh
return (Example expression result)
+instance Binary Hyperlink where
+ put_ bh (Hyperlink url label) = do
+ put_ bh url
+ put_ bh label
+ get bh = do
+ url <- get bh
+ label <- get bh
+ return (Hyperlink url label)
+
{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance (Binary id) => Binary (Doc id) where
@@ -454,7 +463,7 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocCodeBlock al) = do
putByte bh 11
put_ bh al
- put_ bh (DocURL am) = do
+ put_ bh (DocHyperlink am) = do
putByte bh 12
put_ bh am
put_ bh (DocPic x) = do
@@ -469,6 +478,9 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocIdentifierUnchecked x) = do
putByte bh 16
put_ bh x
+ put_ bh (DocWarning ag) = do
+ putByte bh 17
+ put_ bh ag
get bh = do
h <- getByte bh
case h of
@@ -510,7 +522,7 @@ instance (Binary id) => Binary (Doc id) where
return (DocCodeBlock al)
12 -> do
am <- get bh
- return (DocURL am)
+ return (DocHyperlink am)
13 -> do
x <- get bh
return (DocPic x)
@@ -523,6 +535,9 @@ instance (Binary id) => Binary (Doc id) where
16 -> do
x <- get bh
return (DocIdentifierUnchecked x)
+ 17 -> do
+ ag <- get bh
+ return (DocWarning ag)
_ -> fail "invalid binary data found"
diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index f65aee8c..b9ebe688 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -34,6 +34,7 @@ import Data.Char
import Data.Word (Word8)
import Numeric
import System.IO.Unsafe
+import Debug.Trace
}
$ws = $white # \n
@@ -181,7 +182,7 @@ tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para i
go inp@(pos, _, str) sc =
case alexScan inp sc of
AlexEOF -> []
- AlexError _ -> error "lexical error"
+ AlexError _ -> []
AlexSkip inp' _ -> go inp' sc
AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 4e42fd32..46f9def7 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -126,7 +126,7 @@ options backwardsCompat =
Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
"page heading",
Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")
- "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'",
+ "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
Option ['?'] ["help"] (NoArg Flag_Help)
"display this help and exit",
Option ['V'] ["version"] (NoArg Flag_Version)
@@ -229,13 +229,17 @@ optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
-qualification :: [Flag] -> Qualification
+qualification :: [Flag] -> Either String QualOption
qualification flags =
case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
- "full":_ -> FullQual
- "local":_ -> LocalQual Nothing
- "relative":_ -> RelativeQual Nothing
- _ -> NoQual
+ [] -> Right OptNoQual
+ ["none"] -> Right OptNoQual
+ ["full"] -> Right OptFullQual
+ ["local"] -> Right OptLocalQual
+ ["relative"] -> Right OptRelativeQual
+ ["aliased"] -> Right OptAliasedQual
+ [arg] -> Left $ "unknown qualification type " ++ show arg
+ _:_ -> Left "qualification option given multiple times"
verbosity :: [Flag] -> Verbosity
diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y
index e36e8416..b34b14b9 100644
--- a/src/Haddock/Parse.y
+++ b/src/Haddock/Parse.y
@@ -10,7 +10,7 @@
module Haddock.Parse where
import Haddock.Lex
-import Haddock.Types (Doc(..), Example(Example))
+import Haddock.Types (Doc(..), Example(Example), Hyperlink(..))
import Haddock.Doc
import HsSyn
import RdrName
@@ -107,7 +107,7 @@ seq1 :: { Doc RdrName }
elem1 :: { Doc RdrName }
: STRING { DocString $1 }
| '/../' { DocEmphasis (DocString $1) }
- | URL { DocURL $1 }
+ | URL { DocHyperlink (makeHyperlink $1) }
| PIC { DocPic $1 }
| ANAME { DocAName $1 }
| IDENT { DocIdentifier $1 }
@@ -121,6 +121,15 @@ strings :: { String }
happyError :: [LToken] -> Maybe a
happyError toks = Nothing
+-- | Create a `Hyperlink` from given string.
+--
+-- A hyperlink consists of a URL and an optional label. The label is separated
+-- from the url by one or more whitespace characters.
+makeHyperlink :: String -> Hyperlink
+makeHyperlink input = case break isSpace $ strip input of
+ (url, "") -> Hyperlink url Nothing
+ (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label)
+
-- | Create an 'Example', stripping superfluous characters as appropriate
makeExample :: String -> String -> [String] -> Example
makeExample prompt expression result =
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index a3a7db15..fbd05fae 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -24,6 +24,7 @@ import Control.Exception
import Control.Arrow
import Data.Typeable
import Data.Map (Map)
+import Data.Maybe
import qualified Data.Map as Map
import Data.Monoid
import GHC hiding (NoLink)
@@ -42,7 +43,6 @@ 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 GhcDocHdr = Maybe LHsDocString
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -59,19 +59,19 @@ type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
data Interface = Interface
{
-- | The module behind this interface.
- ifaceMod :: Module
+ ifaceMod :: !Module
-- | Original file name of the module.
- , ifaceOrigFilename :: FilePath
+ , ifaceOrigFilename :: !FilePath
-- | Textual information about the module.
, ifaceInfo :: !(HaddockModInfo Name)
-- | Documentation header.
- , ifaceDoc :: !(Maybe (Doc Name))
+ , ifaceDoc :: !(Documentation Name)
-- | Documentation header with cross-reference information.
- , ifaceRnDoc :: Maybe (Doc DocName)
+ , ifaceRnDoc :: !(Documentation DocName)
-- | Haddock options for this module (prune, ignore-exports, etc).
, ifaceOptions :: ![DocOption]
@@ -79,22 +79,22 @@ data Interface = Interface
-- | 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 [LHsDecl Name]
+ , ifaceDeclMap :: !(Map Name [LHsDecl Name])
-- | Documentation of declarations originating from the module (including
-- subordinates).
- , ifaceDocMap :: DocMap Name
- , ifaceArgMap :: ArgMap Name
+ , ifaceDocMap :: !(DocMap Name)
+ , ifaceArgMap :: !(ArgMap Name)
-- | Documentation of declarations originating from the module (including
-- subordinates).
- , ifaceRnDocMap :: DocMap DocName
- , ifaceRnArgMap :: ArgMap DocName
+ , ifaceRnDocMap :: !(DocMap DocName)
+ , ifaceRnArgMap :: !(ArgMap DocName)
- , ifaceSubMap :: Map Name [Name]
+ , ifaceSubMap :: !(Map Name [Name])
, ifaceExportItems :: ![ExportItem Name]
- , ifaceRnExportItems :: [ExportItem DocName]
+ , ifaceRnExportItems :: ![ExportItem DocName]
-- | All names exported by the module.
, ifaceExports :: ![Name]
@@ -104,12 +104,15 @@ data Interface = Interface
-- module.
, ifaceVisibleExports :: ![Name]
+ -- | Aliases of module imports as in @import A.B.C as C@.
+ , ifaceModuleAliases :: !AliasMap
+
-- | Instances exported by the module.
- , ifaceInstances :: ![Instance]
+ , ifaceInstances :: ![ClsInst]
-- | 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)
+ , ifaceHaddockCoverage :: !(Int, Int)
}
@@ -169,62 +172,72 @@ data ExportItem name
= ExportDecl
{
-- | A declaration.
- expItemDecl :: LHsDecl name
+ expItemDecl :: !(LHsDecl name)
-- | Maybe a doc comment, and possibly docs for arguments (if this
-- decl is a function or type-synonym).
- , expItemMbDoc :: DocForDecl name
+ , expItemMbDoc :: !(DocForDecl name)
-- | Subordinate names, possibly with documentation.
- , expItemSubDocs :: [(name, DocForDecl name)]
+ , expItemSubDocs :: ![(name, DocForDecl name)]
-- | Instances relevant to this declaration, possibly with
-- documentation.
- , expItemInstances :: [DocInstance name]
+ , expItemInstances :: ![DocInstance name]
}
-- | An exported entity for which we have no documentation (perhaps because it
-- resides in another package).
| ExportNoDecl
- { expItemName :: name
+ { expItemName :: !name
-- | Subordinate names.
- , expItemSubs :: [name]
+ , expItemSubs :: ![name]
}
-- | A section heading.
| ExportGroup
{
-- | Section level (1, 2, 3, ...).
- expItemSectionLevel :: Int
+ expItemSectionLevel :: !Int
-- | Section id (for hyperlinks).
- , expItemSectionId :: String
+ , expItemSectionId :: !String
-- | Section heading text.
- , expItemSectionText :: Doc name
+ , expItemSectionText :: !(Doc name)
}
-- | Some documentation.
- | ExportDoc (Doc name)
+ | ExportDoc !(Doc name)
-- | A cross-reference to another module.
- | ExportModule Module
+ | ExportModule !Module
+
+data Documentation name = Documentation
+ { documentationDoc :: Maybe (Doc name)
+ , documentationWarning :: !(Maybe (Doc name))
+ } deriving Functor
+
+
+combineDocumentation :: Documentation name -> Maybe (Doc name)
+combineDocumentation (Documentation Nothing Nothing) = Nothing
+combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc)
-- | Arguments and result are indexed by Int, zero-based from the left,
-- because that's the easiest to use when recursing over types.
type FnArgsDoc name = Map Int (Doc name)
-type DocForDecl name = (Maybe (Doc name), FnArgsDoc name)
+type DocForDecl name = (Documentation name, FnArgsDoc name)
noDocForDecl :: DocForDecl name
-noDocForDecl = (Nothing, Map.empty)
+noDocForDecl = (Documentation Nothing Nothing, Map.empty)
unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
-unrenameDocForDecl (mbDoc, fnArgsDoc) =
- (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc)
+unrenameDocForDecl (doc, fnArgsDoc) =
+ (fmap getName doc, (fmap . fmap) getName fnArgsDoc)
-----------------------------------------------------------------------------
@@ -283,13 +296,14 @@ data Doc id
| DocIdentifier id
| DocIdentifierUnchecked (ModuleName, OccName)
| DocModule String
+ | DocWarning (Doc id)
| DocEmphasis (Doc id)
| DocMonospaced (Doc id)
| DocUnorderedList [Doc id]
| DocOrderedList [Doc id]
| DocDefList [(Doc id, Doc id)]
| DocCodeBlock (Doc id)
- | DocURL String
+ | DocHyperlink Hyperlink
| DocPic String
| DocAName String
| DocExamples [Example]
@@ -301,8 +315,10 @@ instance Monoid (Doc id) where
mappend = DocAppend
-unrenameDoc :: Doc DocName -> Doc Name
-unrenameDoc = fmap getName
+data Hyperlink = Hyperlink
+ { hyperlinkUrl :: String
+ , hyperlinkLabel :: Maybe String
+ } deriving (Eq, Show)
data Example = Example
@@ -324,13 +340,14 @@ data DocMarkup id a = Markup
, markupIdentifier :: id -> a
, markupIdentifierUnchecked :: (ModuleName, OccName) -> a
, markupModule :: String -> a
+ , markupWarning :: a -> a
, markupEmphasis :: a -> a
, markupMonospaced :: a -> a
, markupUnorderedList :: [a] -> a
, markupOrderedList :: [a] -> a
, markupDefList :: [(a,a)] -> a
, markupCodeBlock :: a -> a
- , markupURL :: String -> a
+ , markupHyperlink :: Hyperlink -> a
, markupAName :: String -> a
, markupPic :: String -> a
, markupExample :: [Example] -> a
@@ -338,11 +355,11 @@ data DocMarkup id a = Markup
data HaddockModInfo name = HaddockModInfo
- { hmi_description :: Maybe (Doc name)
- , hmi_portability :: Maybe String
- , hmi_stability :: Maybe String
- , hmi_maintainer :: Maybe String
- , hmi_safety :: Maybe String
+ { hmi_description :: (Maybe (Doc name))
+ , hmi_portability :: (Maybe String)
+ , hmi_stability :: (Maybe String)
+ , hmi_maintainer :: (Maybe String)
+ , hmi_safety :: (Maybe String)
}
@@ -373,12 +390,44 @@ data DocOption
-- | Option controlling how to qualify names
+data QualOption
+ = OptNoQual -- ^ Never qualify any names.
+ | OptFullQual -- ^ Qualify all names fully.
+ | OptLocalQual -- ^ Qualify all imported names fully.
+ | OptRelativeQual -- ^ Like local, but strip module prefix
+ -- from modules in the same hierarchy.
+ | OptAliasedQual -- ^ Uses aliases of module names
+ -- as suggested by module import renamings.
+ -- However, we are unfortunately not able
+ -- to maintain the original qualifications.
+ -- Image a re-export of a whole module,
+ -- how could the re-exported identifiers be qualified?
+
+type AliasMap = Map Module ModuleName
+
data Qualification
- = NoQual -- ^ Never qualify any names.
- | FullQual -- ^ Qualify all names fully.
- | LocalQual (Maybe Module) -- ^ Qualify all imported names fully.
- | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix.
- -- from modules in the same hierarchy.
+ = NoQual
+ | FullQual
+ | LocalQual Module
+ | RelativeQual Module
+ | AliasedQual AliasMap Module
+ -- ^ @Module@ contains the current module.
+ -- This way we can distinguish imported and local identifiers.
+
+makeContentsQual :: QualOption -> Qualification
+makeContentsQual qual =
+ case qual of
+ OptNoQual -> NoQual
+ _ -> FullQual
+
+makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
+makeModuleQual qual aliases mdl =
+ case qual of
+ OptLocalQual -> LocalQual mdl
+ OptRelativeQual -> RelativeQual mdl
+ OptAliasedQual -> AliasedQual aliases mdl
+ OptFullQual -> FullQual
+ OptNoQual -> NoQual
-----------------------------------------------------------------------------
@@ -429,7 +478,7 @@ throwE str = throw (HaddockException str)
-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
-- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) }
+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
--instance MonadIO ErrMsgGhc where
-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
--er, implementing GhcMonad involves annoying ExceptionMonad and
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index de97ef85..b8f32589 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Utils
@@ -13,7 +14,7 @@
module Haddock.Utils (
-- * Misc utilities
- restrictTo,
+ restrictTo, emptyHsQTvs,
toDescription, toInstalledDescription,
-- * Filename utilities
@@ -70,7 +71,7 @@ import Data.IORef ( IORef, newIORef, readIORef )
import Data.List ( isSuffixOf )
import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
-import System.Exit ( exitWith, ExitCode(..) )
+import System.Exit
import System.IO ( hPutStr, stderr )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
@@ -125,18 +126,24 @@ toInstalledDescription = hmi_description . instInfo
restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d && tcdND d == DataType ->
- TyClD (d { tcdCons = restrictCons names (tcdCons d) })
- TyClD d | isDataDecl d && tcdND d == NewType ->
- case restrictCons names (tcdCons d) of
- [] -> TyClD (d { tcdND = DataType, tcdCons = [] })
- [con] -> TyClD (d { tcdCons = [con] })
- _ -> error "Should not happen"
+ TyClD d | isDataDecl d ->
+ TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn d) })
TyClD d | isClassDecl d ->
TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
tcdATs = restrictATs names (tcdATs d) })
_ -> decl
+restrictTyDefn :: [Name] -> HsTyDefn Name -> HsTyDefn Name
+restrictTyDefn _ defn@(TySynonym {})
+ = defn
+restrictTyDefn names defn@(TyData { td_ND = new_or_data, td_cons = cons })
+ | DataType <- new_or_data
+ = defn { td_cons = restrictCons names cons }
+ | otherwise -- Newtype
+ = case restrictCons names cons of
+ [] -> defn { td_ND = DataType, td_cons = [] }
+ [con] -> defn { td_cons = [con] }
+ _ -> error "Should not happen"
restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
@@ -156,16 +163,22 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
field_avail (ConDeclField n _ _) = unLoc n `elem` names
field_types flds = [ t | ConDeclField _ t _ <- flds ]
- keep _ | otherwise = Nothing
+ keep _ = Nothing
restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
-restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls
+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]
+emptyHsQTvs :: LHsTyVarBndrs Name
+-- This function is here, rather than in HsTypes, because it *renamed*, but
+-- does not necessarily have all the rigt kind variables. It is used
+-- in Haddock just for printing, so it doesn't matter
+emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
+
--------------------------------------------------------------------------------
-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
@@ -286,7 +299,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName
bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
+bye s = putStr s >> exitSuccess
die :: String -> IO a
@@ -319,7 +332,6 @@ escapeStr = escapeURIString isUnreserved
-- to avoid depending on the network lib, since doing so gives a
-- circular build dependency between haddock and network
-- (at least if you want to build network with haddock docs)
--- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs
escapeURIChar :: (Char -> Bool) -> Char -> String
escapeURIChar p c
| p c = [c]
@@ -410,13 +422,14 @@ 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 (DocWarning d) = markupWarning m (markup m d)
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 (DocHyperlink l) = markupHyperlink m l
markup m (DocAName ref) = markupAName m ref
markup m (DocPic img) = markupPic m img
markup m (DocExamples e) = markupExample m e
@@ -436,13 +449,14 @@ idMarkup = Markup {
markupIdentifier = DocIdentifier,
markupIdentifierUnchecked = DocIdentifierUnchecked,
markupModule = DocModule,
+ markupWarning = DocWarning,
markupEmphasis = DocEmphasis,
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
markupOrderedList = DocOrderedList,
markupDefList = DocDefList,
markupCodeBlock = DocCodeBlock,
- markupURL = DocURL,
+ markupHyperlink = DocHyperlink,
markupAName = DocAName,
markupPic = DocPic,
markupExample = DocExamples
diff --git a/src/Main.hs b/src/Main.hs
index 0a3c9ffc..31e2726c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Main
@@ -57,6 +57,7 @@ import Paths_haddock
import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
+import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)
import Panic (panic, handleGhcException)
import Module
@@ -126,35 +127,14 @@ main :: IO ()
main = handleTopExceptions $ do
-- Parse command-line flags and handle some of them initially.
+ -- TODO: unify all of this (and some of what's in the 'render' function),
+ -- into one function that returns a record with a field for each option,
+ -- or which exits with an error or help message.
args <- getArgs
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
+ qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
- if not (null files) then do
- (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
-
- -- Dump an "interface file" (.haddock file), if requested.
- case optDumpInterfaceFile flags of
- Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
- Nothing -> return ()
-
- -- Render the interfaces.
- renderStep flags packages ifaces
-
- else do
- when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
- throwE "No input file(s)."
-
- -- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags)
-
- -- Render even though there are no input files (usually contents/index).
- renderStep flags packages []
-
-
-readPackagesAndProcessModules :: [Flag] -> [String]
- -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
-readPackagesAndProcessModules flags files = do
libDir <- fmap snd (getGhcDirs flags)
-- Catches all GHC source errors, then prints and re-throws them.
@@ -165,6 +145,33 @@ readPackagesAndProcessModules flags files = do
-- Initialize GHC.
withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+ dflags <- getDynFlags
+
+ if not (null files) then do
+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+ -- Dump an "interface file" (.haddock file), if requested.
+ case optDumpInterfaceFile flags of
+ Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+ Nothing -> return ()
+
+ -- Render the interfaces.
+ liftIO $ renderStep dflags flags qual packages ifaces
+
+ else do
+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+ throwE "No input file(s)."
+
+ -- Get packages supplied with --read-interface.
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+
+ -- Render even though there are no input files (usually contents/index).
+ liftIO $ renderStep dflags flags qual packages []
+
+
+readPackagesAndProcessModules :: [Flag] -> [String]
+ -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
@@ -175,19 +182,19 @@ readPackagesAndProcessModules flags files = do
return (packages, ifaces, homeLinks)
-renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep flags pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags qual pkgs interfaces = do
updateHTMLXRefs pkgs
let
ifaceFiles = map snd pkgs
installedIfaces = concatMap ifInstalledIfaces ifaceFiles
srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
- render flags interfaces installedIfaces srcMap
+ render dflags flags qual interfaces installedIfaces srcMap
-- | Render the interfaces with whatever backend is specified in the flags.
-render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render flags ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render dflags flags qual ifaces installedIfaces srcMap = do
let
title = fromMaybe "" (optTitle flags)
@@ -198,7 +205,6 @@ render flags ifaces installedIfaces srcMap = do
opt_index_url = optIndexUrl flags
odir = outputDir flags
opt_latex_style = optLaTeXStyle flags
- opt_qualification = qualification flags
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -228,20 +234,21 @@ render flags ifaces installedIfaces srcMap = do
when (Flag_GenContents `elem` flags) $ do
ppHtmlContents odir title pkgStr
themes opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty opt_qualification
+ allVisibleIfaces True prologue pretty
+ (makeContentsQual qual)
copyHtmlBits odir libDir themes
when (Flag_Html `elem` flags) $ do
ppHtml title pkgStr visibleIfaces odir
prologue
themes sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode opt_qualification
+ opt_contents_url opt_index_url unicode qual
pretty
copyHtmlBits odir libDir themes
when (Flag_Hoogle `elem` flags) $ do
let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
- ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir
+ ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
when (Flag_LaTeX `elem` flags) $ do
ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
@@ -290,7 +297,7 @@ dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile
-- | Start a GHC session with the -haddock flag set. Also turn off
-- compilation and linking. Then run the given 'Ghc' action.
withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
-withGhc libDir flags ghcActs = do
+withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do
-- TODO: handle warnings?
(restFlags, _) <- parseStaticFlags (map noLoc flags)
runGhc (Just libDir) $ do
@@ -308,6 +315,7 @@ withGhc libDir flags ghcActs = do
-- dynamic or static linking at all!
_ <- setSessionDynFlags dynflags'''
ghcActs dynflags'''
+ `finally` restoreStaticFlagGlobals savedFlags
where
parseGhcFlags :: Monad m => DynFlags -> [Located String]
-> [String] -> m DynFlags
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 16:35:58 +0000