haddock 2.0.0.0 → 2.1.0
raw patch · 21 files changed
+237/−200 lines, 21 files
Files
- CHANGES +13/−0
- TODO +21/−11
- doc/haddock.xml +1/−1
- haddock.cabal +8/−6
- haddock.spec +1/−1
- src/Distribution/Haddock.hs +3/−1
- src/Haddock/Backends/DevHelp.hs +2/−2
- src/Haddock/Backends/Html.hs +59/−51
- src/Haddock/Comments.hs +0/−15
- src/Haddock/DocName.hs +53/−0
- src/Haddock/Exception.hs +3/−0
- src/Haddock/GHC/Utils.hs +13/−36
- src/Haddock/Interface.hs +11/−11
- src/Haddock/Interface/AttachInstances.hs +4/−1
- src/Haddock/Interface/Rename.hs +13/−12
- src/Haddock/InterfaceFile.hs +7/−25
- src/Haddock/ModuleTree.hs +1/−1
- src/Haddock/Options.hs +3/−1
- src/Haddock/Types.hs +9/−15
- src/Haddock/Utils.hs +9/−6
- src/Main.hs +3/−4
CHANGES view
@@ -1,3 +1,16 @@+Changes in version 2.1.0:++ * Fix a bug that made links point to the defining module instead+ of the "best" one (e.g Int pointing to GHC.Base instead of Data.Int)++ * Fix a couple of smaller bugs++ * The representation of DocName was changed in the library++ * Add a flag --no-warnings for turning off warnings++-----------------------------------------------------------------------------+ Changes in version 2.0.0.0: * The GHC API is used as the front-end
TODO view
@@ -20,6 +20,9 @@ ----------------------------------------------------------------------------- -- bugs +* parser doesn't support doc comments on types in type aliases:+ type MyInt = Int -- ^ comment+ * HsParser bug: starting the module with '-- | doc' followed by a declaration doesn't parse, because the '-- | doc' is interpreted as the module documentation (the grammar has an S/R conflict because of this).@@ -43,21 +46,10 @@ target module is imported without hiding any of its exports (otherwise we should inline just the exported bits). -* remove the s/r conflicts I added to the grammar--* Support for the rest of GHC extensions in the parser:- - scoped type variables (return types left to do).- - template haskell- - explicit kind annotations- - infix type constructors- * Be a bit cleaner about error cases: some internal errors can be generated by bugs in the Haskell source. Divide out the proper internal error cases and emit proper error messages. -* derived instance support isn't quite right (doing it properly is - hard, though).- * The synopsis generated for a module with no docs should not attempt to link to the doc for each entity. We need a different kind of summary here: what we really want is just the documentation section but without@@ -73,6 +65,24 @@ ----------------------------------------------------------------------------- -- features+++* Optionally show qualifications of identifiers, that is print+"Sequence.map" rather than "map", "Music.T" rather than just "T". The+option for haddock could be+ --qualification QUAL+ QUAL=none (default) strip off qualification (just "map")+ QUAL=orig show the identifiers as they are written in the module (e.g. "map" or "List.map")+ QUAL=full show all identifiers with full qualification (Data.List.map)+ Actually I tried to implement it by myself in the old Haddock, but I+could not precisely identify the place, where the qualification is+removed.++* Documentation of arguments of type constructors other than 'top level' arrows. E.g.+ T (a {- ^ arg -} -> b {- ^ result -} )+ (a {- ^ arg -} -> b {- ^ result -} ) -> c+ (a {- ^ x coord -}, b {- ^ y coord -}) -> c+ It's probably difficult to format properly in HTML. * Do something better about re-exported symbols from another package.
doc/haddock.xml view
@@ -16,7 +16,7 @@ <holder>Simon Marlow</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.0.0.0, a Haskell+ <para>This document describes Haddock version 2.1.0, a Haskell documentation tool.</para> </abstract> </bookinfo>
haddock.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.2 build-type: Simple name: haddock-version: 2.0.0.0+version: 2.1.0 license: BSD3 license-file: LICENSE copyright: (c) Simon Marlow, David Waern@@ -9,6 +9,7 @@ maintainer: David Waern <david.waern@gmail.com> stability: experimental homepage: http://www.haskell.org/haddock/+synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries category: Development@@ -21,8 +22,8 @@ pretty, containers, array-extensions: CPP, PatternGuards-ghc-options: -fglasgow-exts+extensions: CPP, PatternGuards, DeriveDataTypeable,+ PatternSignatures, MagicHash hs-source-dirs: src exposed-modules: Distribution.Haddock other-modules:@@ -75,8 +76,9 @@ executable: haddock hs-source-dirs: src main-is: Main.hs-extensions: CPP, PatternGuards-ghc-options: -fglasgow-exts -funbox-strict-fields -O2 -fasm+extensions: CPP, PatternGuards, DeriveDataTypeable,+ PatternSignatures, MagicHash+ghc-options: -funbox-strict-fields -O2 other-modules: Haddock.Interface Haddock.Interface.Rename@@ -94,6 +96,7 @@ Haddock.Backends.Hoogle Haddock.ModuleTree Haddock.Types+ Haddock.DocName Haddock.Version Haddock.InterfaceFile Haddock.Exception@@ -101,4 +104,3 @@ Haddock.GHC.Typecheck Haddock.GHC.Utils Haddock.GHC- Haddock.Comments
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.0.0.0+%define version 2.1.0 %define release 1 Name: %{name}
src/Distribution/Haddock.hs view
@@ -9,9 +9,11 @@ readInterfaceFile, InterfaceFile(..), LinkEnv,- InstalledInterface(..)+ InstalledInterface(..),+ DocName(..) ) where import Haddock.InterfaceFile import Haddock.Types+import Haddock.DocName
src/Haddock/Backends/DevHelp.hs view
@@ -12,7 +12,7 @@ import Module ( moduleName, moduleNameString, Module, mkModule, mkModuleName ) import PackageConfig ( stringToPackageId )-import Name ( Name, nameModule, getOccString )+import Name ( Name, nameModule, getOccString, nameOccName ) import Data.Maybe ( fromMaybe ) import qualified Data.Map as Map@@ -77,5 +77,5 @@ ppReference :: Name -> [Module] -> Doc ppReference name [] = empty ppReference name (mod:refs) = - text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod name)<>text"\"/>" $$+ text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod (nameOccName name))<>text"\"/>" $$ ppReference name refs
src/Haddock/Backends/Html.hs view
@@ -14,6 +14,7 @@ import Prelude hiding (div) +import Haddock.DocName import Haddock.Backends.DevHelp import Haddock.Backends.HH import Haddock.Backends.HH2@@ -660,7 +661,7 @@ where doDecl (TyClD d) = doTyClD d doDecl (SigD (TypeSig (L _ n) (L _ t))) = - ppFunSig summary links loc mbDoc (getName n) t+ ppFunSig summary links loc mbDoc (docNameOrig n) t doDecl (ForD d) = ppFor summary links loc mbDoc d doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0@@ -672,7 +673,8 @@ Name -> HsType DocName -> HtmlTable ppFunSig summary links loc mbDoc name typ = ppTypeOrFunSig summary links loc name typ mbDoc - (ppTypeSig summary name typ, ppBinder False name, dcolon)+ (ppTypeSig summary (nameOccName name) typ, + ppBinder False (nameOccName name), dcolon) ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> Name -> HsType DocName ->@@ -721,10 +723,10 @@ ppTyVars tvs = ppTyNames (tyvarNames tvs) tyvarNames = map f - where f x = let NoLink n = hsTyVarName (unLoc x) in n+ where f x = docNameOrig . hsTyVarName . unLoc $ x ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _)- = ppFunSig summary links loc mbDoc (getName name) typ+ = ppFunSig summary links loc mbDoc (docNameOrig name) typ ppFor _ _ _ _ _ = error "ppFor" -- we skip type patterns for now@@ -732,12 +734,13 @@ = ppTypeOrFunSig summary links loc n (unLoc ltype) mbDoc (full, hdr, spaceHtml +++ equals) where- hdr = hsep ([keyword "type", ppBinder summary n] ++ ppTyVars ltyvars)+ hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) full = hdr <+> equals <+> ppLType ltype- NoLink n = name+ n = docNameOrig name+ occ = docNameOcc name -ppTypeSig :: Bool -> Name -> HsType DocName -> Html+ppTypeSig :: Bool -> OccName -> HsType DocName -> Html ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty @@ -762,7 +765,7 @@ -- | Print an application of a DocName and a list of Names ppDataClassHead :: Bool -> DocName -> [Name] -> Html ppDataClassHead summ n ns = - ppTypeApp n ns (ppBinder summ . getName) ppTyName+ ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName -- | General printing of type applications@@ -771,7 +774,7 @@ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where- operator = isNameSym . getName $ n+ operator = isNameSym . docNameOrig $ n opApp = ppT t1 <+> ppDN n <+> ppT t2 ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)@@ -835,12 +838,12 @@ vanillaTable << aboves ([ ppAT summary at | L _ at <- ats ] ++ [ ppFunSig summary links loc mbDoc n typ- | L _ (TypeSig (L _ (NoLink n)) (L _ typ)) <- sigs- , let mbDoc = Map.lookup n docMap ])+ | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs+ , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ]) ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds- NoLink nm = unLoc lname+ nm = docNameOrig . unLoc $ lname ppAT summary at = case at of TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)@@ -863,7 +866,7 @@ | null lsigs = topDeclBox links loc nm hdr | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") - NoLink nm = unLoc lname+ nm = docNameOrig . unLoc $ lname ctxt = unLoc lctxt hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds@@ -877,9 +880,9 @@ | otherwise = s8 </> methHdr </> tda [theclass "body"] << vanillaTable << (- abovesSep s8 [ ppFunSig summary links loc mbDoc (orig n) typ- | L _ (TypeSig n (L _ typ)) <- lsigs- , let mbDoc = Map.lookup (orig n) docMap ]+ abovesSep s8 [ ppFunSig summary links loc mbDoc (docNameOrig n) typ+ | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs+ , let mbDoc = Map.lookup (docNameOrig n) docMap ] ) instId = collapseId nm@@ -901,10 +904,7 @@ -- ----------------------------------------------------------------------------- -- Data & newtype declarations -orig (L _ (NoLink name)) = name-orig _ = error "orig" - -- TODO: print contexts ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Html@@ -937,7 +937,7 @@ doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con)) doGADTConstr con = declBox (ppShortConstr summary (unLoc con)) - name = orig (tcdLName dataDecl)+ name = docNameOrig . unLoc . tcdLName $ dataDecl context = unLoc (tcdCtxt dataDecl) newOrData = tcdND dataDecl tyVars = tyvarNames (tcdTyVars dataDecl)@@ -962,7 +962,7 @@ where- name = orig (tcdLName dataDecl)+ name = docNameOrig . unLoc . tcdLName $ dataDecl context = unLoc (tcdCtxt dataDecl) newOrData = tcdND dataDecl tyVars = tyvarNames (tcdTyVars dataDecl)@@ -1019,11 +1019,11 @@ ppShortConstr summary con = case con_res con of ResTyH98 -> case con_details con of - PrefixCon args -> header +++ hsep (ppBinder summary name : map ppLType args)- RecCon fields -> header +++ ppBinder summary name <+>+ PrefixCon args -> header +++ hsep (ppBinder summary occ : map ppLParendType args)+ RecCon fields -> header +++ ppBinder summary occ <+> braces (vanillaTable << aboves (map (ppShortField summary) fields)) InfixCon arg1 arg2 -> header +++ - hsep [ppLType arg1, ppBinder summary name, ppLType arg2] + hsep [ppLParendType arg1, ppBinder summary occ, ppLParendType arg2] ResTyGADT resTy -> case con_details con of PrefixCon args -> doGADTCon args resTy@@ -1031,12 +1031,12 @@ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy where- doGADTCon args resTy = ppBinder summary name <+> dcolon <+> hsep [+ doGADTCon args resTy = ppBinder summary occ <+> dcolon <+> hsep [ ppForAll forall ltvs lcontext, ppLType (foldr mkFunTy resTy args) ] header = ppConstrHdr forall tyVars context- name = orig (con_name con)+ occ = docNameOcc . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con@@ -1060,17 +1060,17 @@ ResTyH98 -> case con_details con of PrefixCon args -> - argBox (hsep ((header +++ ppBinder False name) : map ppLType args)) + argBox (hsep ((header +++ ppBinder False occ) : map ppLParendType args)) <-> maybeRDocBox mbLDoc RecCon fields -> - argBox (header +++ ppBinder False name) <->+ argBox (header +++ ppBinder False occ) <-> maybeRDocBox mbLDoc </> (tda [theclass "body"] << spacedTable1 << aboves (map ppSideBySideField fields)) InfixCon arg1 arg2 -> - argBox (hsep [header+++ppLType arg1, ppBinder False name, ppLType arg2])+ argBox (hsep [header+++ppLParendType arg1, ppBinder False occ, ppLParendType arg2]) <-> maybeRDocBox mbLDoc ResTyGADT resTy -> case con_details con of@@ -1079,14 +1079,14 @@ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy where - doGADTCon args resTy = argBox (ppBinder False name <+> dcolon <+> hsep [+ doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon <+> hsep [ ppForAll forall ltvs (con_cxt con), ppLType (foldr mkFunTy resTy args) ] ) <-> maybeRDocBox mbLDoc header = ppConstrHdr forall tyVars context- name = orig (con_name con)+ occ = docNameOcc . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con)@@ -1095,8 +1095,8 @@ mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: ConDeclField DocName -> HtmlTable-ppSideBySideField (ConDeclField lname ltype mbLDoc) =- argBox (ppBinder False (orig lname)+ppSideBySideField (ConDeclField (L _ name) ltype mbLDoc) =+ argBox (ppBinder False (docNameOcc name) <+> dcolon <+> ppLType ltype) <-> maybeRDocBox mbLDoc @@ -1128,9 +1128,9 @@ -} ppShortField :: Bool -> ConDeclField DocName -> HtmlTable-ppShortField summary (ConDeclField lname ltype _) +ppShortField summary (ConDeclField (L _ name) ltype _) = tda [theclass "recfield"] << (- ppBinder summary (orig lname)+ ppBinder summary (docNameOcc name) <+> dcolon <+> ppLType ltype ) @@ -1272,8 +1272,8 @@ = maybeParen ctxt_prec pREC_OP $ ppr_mono_lty pREC_OP ty1 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 where- ppr_op = if not (isNameSym name) then quote (ppLDocName op) else ppLDocName op- name = getName . unLoc $ op+ ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op+ occName = docNameOcc . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty) = parens (ppr_mono_lty pREC_TOP ty)@@ -1292,7 +1292,7 @@ -- Names ppOccName :: OccName -> Html-ppOccName name = toHtml $ occNameString name+ppOccName = toHtml . occNameString ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc@@ -1300,28 +1300,36 @@ ppLDocName (L _ d) = ppDocName d ppDocName :: DocName -> Html-ppDocName (Link name) = linkId (nameModule name) (Just name) << ppName name-ppDocName (NoLink name) = toHtml (getOccString name)+ppDocName (Documented name mod) = + linkIdOcc mod (Just occName) << ppOccName occName+ where occName = nameOccName name+ppDocName (Undocumented name) = toHtml (getOccString name) -linkTarget :: Name -> Html-linkTarget name = namedAnchor (anchorNameStr name) << toHtml "" +linkTarget :: OccName -> Html+linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" ppName :: Name -> Html ppName name = toHtml (getOccString name) -ppBinder :: Bool -> Name -> Html++ppBinder :: Bool -> OccName -> Html -- The Bool indicates whether we are generating the summary, in which case -- the binder will be a link to the full definition.-ppBinder True nm = linkedAnchor (anchorNameStr nm) << ppBinder' nm-ppBinder False nm = linkTarget nm +++ bold << ppBinder' nm+ppBinder True n = linkedAnchor (anchorNameStr n) << ppBinder' n+ppBinder False n = linkTarget n +++ bold << ppBinder' n -ppBinder' :: Name -> Html-ppBinder' name- | isNameVarSym name = parens $ toHtml (getOccString name)- | otherwise = toHtml (getOccString name) -linkId :: Module -> Maybe Name -> Html -> Html-linkId mod mbName = anchor ! [href hr]+ppBinder' :: OccName -> Html+ppBinder' n+ | isVarSym n = parens $ ppOccName n+ | otherwise = ppOccName n+++linkId mod mbName = linkIdOcc mod (fmap nameOccName mbName)+++linkIdOcc :: Module -> Maybe OccName -> Html -> Html+linkIdOcc mod mbName = anchor ! [href hr] where hr = case mbName of Nothing -> moduleHtmlFile mod
− src/Haddock/Comments.hs
@@ -1,15 +0,0 @@-module Haddock.Comments where--import Data.Generics-import Data.Typeable-import SrcLoc--deriving instance Typeable1 Located--next :: (Data a, Typeable b) => SrcSpan -> a -> [Located b]-next span term = locatedTerms term--locatedTerms :: (Data a, Typeable b) => a -> [Located b]-locatedTerms terms = listify (\(L _ _) -> True) terms--
+ src/Haddock/DocName.hs view
@@ -0,0 +1,53 @@+--+-- Haddock - A Haskell Documentation Tool+--+-- (c) Simon Marlow 2003+--+++{-# OPTIONS_HADDOCK hide #-}+++module Haddock.DocName where+++import Haddock.GHC.Utils++import GHC+import OccName+import Name+import Binary+import Outputable+++data DocName = Documented Name Module | Undocumented Name+++docNameOcc :: DocName -> OccName+docNameOcc = nameOccName . docNameOrig+++docNameOrig :: DocName -> Name+docNameOrig (Documented name _) = name+docNameOrig (Undocumented name) = name+++instance Binary DocName where+ put_ bh (Documented name mod) = do+ putByte bh 0+ put_ bh name+ put_ bh mod+ put_ bh (Undocumented name) = do+ putByte bh 1+ put_ bh name++ get bh = do+ h <- getByte bh+ case h of+ 0 -> do+ name <- get bh+ mod <- get bh+ return (Documented name mod)+ 1 -> do+ name <- get bh+ return (Undocumented name)
src/Haddock/Exception.hs view
@@ -5,6 +5,9 @@ -- +{-# LANGUAGE DeriveDataTypeable #-}++ module Haddock.Exception ( HaddockException, throwE
src/Haddock/GHC/Utils.hs view
@@ -5,65 +5,45 @@ -- +{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++ module Haddock.GHC.Utils where -import Debug.Trace import Data.Char import qualified Data.Map as Map import GHC import HsSyn import SrcLoc-import HscTypes import Outputable-import Packages-import UniqFM import Name----- names--nameOccString = occNameString . nameOccName ---nameSetMod n newMod = - mkExternalName (nameUnique n) newMod (nameOccName n) (nameSrcSpan n)---nameSetPkg pkgId n = - mkExternalName (nameUnique n) (mkModule pkgId (moduleName mod)) - (nameOccName n) (nameSrcSpan n)- where mod = nameModule n----- modules+import Packages moduleString :: Module -> String moduleString = moduleNameString . moduleName -mkModuleNoPkg :: String -> Module-mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)-- modulePkgStr = packageIdString . modulePackageId --- Instances+mkModuleNoPkg :: String -> Module+mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str) instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where ppr m = ppr (Map.toList m) --- misc+isNameSym :: Name -> Bool+isNameSym = isSymOcc . nameOccName -isNameSym n = isNameVarSym n || isNameConSym n-isNameVarSym = isLexVarSym . occNameFS . nameOccName -isNameConSym = isLexConSym . occNameFS . nameOccName +isVarSym :: OccName -> Bool+isVarSym = isLexVarSym . occNameFS getMainDeclBinder :: HsDecl name -> Maybe name@@ -74,16 +54,13 @@ (name:_) -> Just (unLoc name) getMainDeclBinder (SigD d) = sigNameNoLoc d getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)-getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing+getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing getMainDeclBinder _ = Nothing --- To keep if if minf_iface is re-introduced---modInfoName = moduleName . mi_module . minf_iface---modInfoMod = mi_module . minf_iface - pretty :: Outputable a => a -> String pretty x = show (ppr x defaultUserStyle) +trace_ppr :: Outputable a => a -> b -> b trace_ppr x y = trace (showSDoc (ppr x)) y
src/Haddock/Interface.hs view
@@ -14,6 +14,7 @@ ) where +import Haddock.DocName import Haddock.Interface.Create import Haddock.Interface.AttachInstances import Haddock.Interface.Rename@@ -49,7 +50,8 @@ let interfaces' = attachInstances interfaces allNames -- part 3, rename the interfaces- interfaces'' <- mapM (renameInterface links) interfaces'+ let warnings = Flag_NoWarnings `notElem` flags+ interfaces'' <- mapM (renameInterface links warnings) interfaces' return (interfaces'', homeLinks) @@ -74,17 +76,15 @@ -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. buildHomeLinks :: [Interface] -> LinkEnv-buildHomeLinks modules = foldl upd Map.empty (reverse modules)+buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) where- upd old_env mod- | OptHide `elem` ifaceOptions mod = old_env- | OptNotHome `elem` ifaceOptions mod =+ upd old_env iface+ | OptHide `elem` ifaceOptions iface = old_env+ | OptNotHome `elem` ifaceOptions iface = foldl' keep_old old_env exported_names | otherwise = foldl' keep_new old_env exported_names where- exported_names = ifaceVisibleExports mod- modName = ifaceMod mod-- keep_old env n = Map.insertWith (\new old -> old) n- (nameSetMod n modName) env- keep_new env n = Map.insert n (nameSetMod n modName) env+ exported_names = ifaceVisibleExports iface+ mod = ifaceMod iface+ keep_old env n = Map.insertWith (\new old -> old) n mod env+ keep_new env n = Map.insert n mod env
src/Haddock/Interface/AttachInstances.hs view
@@ -5,6 +5,9 @@ -- +{-# LANGUAGE MagicHash #-}++ module Haddock.Interface.AttachInstances (attachInstances) where @@ -133,7 +136,7 @@ TyConApp tc ts -> case ts of t1:t2:rest- | isNameConSym . tyConName $ tc ->+ | isSymOcc . nameOccName . tyConName $ tc -> app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest _ -> app (tycon tc) ts
src/Haddock/Interface/Rename.hs view
@@ -8,6 +8,7 @@ module Haddock.Interface.Rename (renameInterface) where +import Haddock.DocName import Haddock.Types import Haddock.GHC.Utils @@ -28,14 +29,14 @@ import Control.Monad hiding (mapM) -renameInterface :: LinkEnv -> Interface -> ErrMsgM Interface-renameInterface renamingEnv mod =+renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface+renameInterface renamingEnv warnings mod = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming -- env let localEnv = foldl fn renamingEnv (ifaceVisibleExports mod)- where fn env name = Map.insert name (nameSetMod name (ifaceMod mod)) env+ where fn env name = Map.insert name (ifaceMod mod) env docs = Map.toList (ifaceDocMap mod) renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') @@ -65,10 +66,10 @@ in do -- report things that we couldn't link to. Only do this for non-hidden -- modules.- when (OptHide `notElem` ifaceOptions mod && not (null strings)) $- tell ["Warning: " ++ show (ppr (ifaceMod mod) defaultUserStyle) ++ - ": could not find link destinations for:\n"++- " " ++ concat (map (' ':) strings) ]+ unless (OptHide `elem` ifaceOptions mod || null strings || not warnings) $+ tell ["Warning: " ++ show (ppr (ifaceMod mod) defaultUserStyle) +++ ": could not find link destinations for:\n"+++ " " ++ concat (map (' ':) strings) ] return $ mod { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap,@@ -119,8 +120,8 @@ runRnFM env rn = unRn rn lkp where lkp n = case Map.lookup n env of- Nothing -> (False, NoLink n) - Just q -> (True, Link q)+ Nothing -> (False, Undocumented n) + Just mod -> (True, Documented n mod) --------------------------------------------------------------------------------@@ -128,8 +129,8 @@ -------------------------------------------------------------------------------- -keep n = NoLink n-keepL (L loc n) = L loc (NoLink n)+keep n = Undocumented n+keepL (L loc n) = L loc (Undocumented n) rename = lookupRn id @@ -162,7 +163,7 @@ lkp <- getLookupRn case [ n | (True, n) <- map lkp ids ] of ids'@(_:_) -> return (DocIdentifier ids')- [] -> return (DocIdentifier (map NoLink ids))+ [] -> return (DocIdentifier (map Undocumented ids)) DocModule str -> return (DocModule str) DocEmphasis doc -> do doc' <- renameDoc doc
src/Haddock/InterfaceFile.hs view
@@ -12,6 +12,7 @@ ) where +import Haddock.DocName () import Haddock.Types import Haddock.Exception @@ -44,11 +45,14 @@ } -binaryInterfaceMagic = 0xD0Cface :: Word32-binaryInterfaceVersion = 0 :: Word16+binaryInterfaceMagic :: Word32+binaryInterfaceMagic = 0xD0Cface +binaryInterfaceVersion :: Word16+binaryInterfaceVersion = 1 -initBinMemSize = (1024*1024) :: Int+initBinMemSize :: Int+initBinMemSize = 1024*1024 writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()@@ -99,8 +103,6 @@ -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. If given a GHC 'Session', the function -- registers all read names in the name cache of the session.--- The aim is to be compatible with interface files produced by any Haddock --- of version 2.0.0.0 or greater. readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile) readInterfaceFile mbSession filename = do bh <- readBinMem filename@@ -242,26 +244,6 @@ exps <- get bh visExps <- get bh return (InstalledInterface mod info (Map.fromList docMap) exps visExps)---{-* Generated by DrIFT : Look, but Don't Touch. *-}-instance Binary DocName where- put_ bh (Link aa) = do- putByte bh 0- put_ bh aa- put_ bh (NoLink ab) = do- putByte bh 1- put_ bh ab- get bh = do- h <- getByte bh- case h of- 0 -> do- aa <- get bh- return (Link aa)- 1 -> do- ab <- get bh- return (NoLink ab)- _ -> fail "invalid binary data found" instance Binary DocOption where
src/Haddock/ModuleTree.hs view
@@ -6,7 +6,7 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.Types ( DocName )+import Haddock.DocName import GHC ( HsDoc, Name ) import Module ( Module, moduleNameString, moduleName, modulePackageId ) import PackageConfig ( packageIdString )
src/Haddock/Options.hs view
@@ -83,6 +83,7 @@ | Flag_OptGhc String | Flag_GhcLibDir String | Flag_GhcVersion+ | Flag_NoWarnings deriving (Eq) @@ -149,5 +150,6 @@ Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") "Forward option to GHC", Option [] ["ghc-version"] (NoArg Flag_GhcVersion)- "output GHC version in numeric format"+ "output GHC version in numeric format",+ Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings" ]
src/Haddock/Types.hs view
@@ -5,16 +5,24 @@ -- +{-# OPTIONS_HADDOCK hide #-}++ module Haddock.Types where +import Haddock.GHC.Utils+import Haddock.DocName+ import Data.Map (Map) import qualified Data.Map as Map import GHC hiding (NoLink) import Outputable import OccName+import Name + {-! for DocOption derive: Binary !-} data DocOption = OptHide -- ^ This module should not appear in the docs@@ -78,21 +86,7 @@ type InstHead name = ([HsPred name], name, [HsType name]) type ModuleMap = Map Module Interface type DocMap = Map Name (HsDoc DocName)-type LinkEnv = Map Name Name---{-! for DocName derive: Binary !-}-data DocName = Link Name | NoLink Name---instance Outputable DocName where- ppr (Link n) = ppr n- ppr (NoLink n) = ppr n---instance NamedThing DocName where- getName (Link n) = n- getName (NoLink n) = n+type LinkEnv = Map Name Module -- | This structure holds the module information we get from GHC's
src/Haddock/Utils.hs view
@@ -5,6 +5,10 @@ -- (c) Simon Marlow 2003 -- ++{-# LANGUAGE PatternSignatures #-}++ module Haddock.Utils ( -- * Misc utilities@@ -167,8 +171,8 @@ mdl' = map (\c -> if c == '.' then '-' else c) (moduleNameString (moduleName mdl)) -nameHtmlRef :: Module -> Name -> String -nameHtmlRef mdl str = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr str)+nameHtmlRef :: Module -> OccName -> String +nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n) contentsHtmlFile, indexHtmlFile :: String contentsHtmlFile = "index.html"@@ -179,10 +183,9 @@ where b | isAlpha a = [a] | otherwise = show (ord a) -anchorNameStr :: Name -> String-anchorNameStr name | isValOcc occName = "v:" ++ getOccString name - | otherwise = "t:" ++ getOccString name- where occName = nameOccName name+anchorNameStr :: OccName -> String+anchorNameStr name | isValOcc name = "v:" ++ occNameString name + | otherwise = "t:" ++ occNameString name pathJoin :: [FilePath] -> FilePath pathJoin = foldr join []
src/Main.hs view
@@ -10,11 +10,10 @@ module Main (main) where -import Haddock.Comments import Haddock.Backends.Html import Haddock.Backends.Hoogle import Haddock.Interface-import Haddock.Types hiding (NoLink)+import Haddock.Types import Haddock.Version import Haddock.InterfaceFile import Haddock.Exception@@ -287,8 +286,8 @@ throwE ("-h cannot be used with --gen-index or --gen-contents") where byeVersion = bye $- "Haddock version " ++ projectVersion ++ - ", (c) Simon Marlow 2006; ported to the GHC-API by David Waern 2006-2007\n"+ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"+ ++ "Ported to use the GHC API by David Waern 2006-2008\n" byeGhcVersion = bye $ (fromJust $ lookup "Project version" $ compilerInfo) ++ "\n"