From fba37778cd3eb564c83f1a35e922b8a0a9f111ea Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 28 Nov 2009 20:15:30 +0000 Subject: Rename HsDoc back into Doc --- src/Haddock/Backends/Hoogle.hs | 8 ++-- src/Haddock/Backends/Html.hs | 28 ++++++------- src/Haddock/Doc.hs | 64 ++++++++++++++++++++++++++++++ src/Haddock/HsDoc.hs | 64 ------------------------------ src/Haddock/Interface/AttachInstances.hs | 2 +- src/Haddock/Interface/LexParseRn.hs | 14 +++---- src/Haddock/Interface/Parse.y | 26 ++++++------ src/Haddock/Interface/ParseModuleHeader.hs | 4 +- src/Haddock/Interface/Rename.hs | 6 +-- src/Haddock/Interface/Rn.hs | 8 ++-- src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/ModuleTree.hs | 10 ++--- src/Haddock/Types.hs | 49 +++++++++++------------ src/Haddock/Utils.hs | 12 +++--- 14 files changed, 148 insertions(+), 149 deletions(-) create mode 100644 src/Haddock/Doc.hs delete mode 100644 src/Haddock/HsDoc.hs (limited to 'src/Haddock') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 3412033d..9958faeb 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -35,7 +35,7 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: String -> String -> String -> Maybe (HsDoc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ @@ -168,7 +168,7 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : f w = if w == nam then operator nam else w -- | for constructors, and named-fields... -lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (HsDoc Name) +lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) lookupCon subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> d _ -> Nothing @@ -198,11 +198,11 @@ ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) --------------------------------------------------------------------- -- DOCUMENTATION -doc :: Outputable o => Maybe (HsDoc o) -> [String] +doc :: Outputable o => Maybe (Doc o) -> [String] doc = docWith "" -docWith :: Outputable o => String -> Maybe (HsDoc o) -> [String] +docWith :: Outputable o => String -> Maybe (Doc o) -> [String] docWith [] Nothing = [] docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index c29f2483..37c9cca0 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -63,7 +63,7 @@ ppHtml :: String -> Maybe String -- package -> [Interface] -> FilePath -- destination directory - -> Maybe (HsDoc GHC.RdrName) -- prologue text, maybe + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe -> Maybe String -- the Html Help format (--html-help) -> SourceURLs -- the source URL (--source) -> WikiURLs -- the wiki URL (--wiki) @@ -306,7 +306,7 @@ ppHtmlContents -> Maybe String -> SourceURLs -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (HsDoc GHC.RdrName) + -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) -> IO () ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url @@ -341,7 +341,7 @@ ppHtmlContents odir doctitle Just "devhelp" -> return () Just format -> fail ("The "++format++" format is not implemented") -ppPrologue :: String -> Maybe (HsDoc GHC.RdrName) -> HtmlTable +ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> HtmlTable ppPrologue _ Nothing = Html.emptyTable ppPrologue title (Just doc) = (tda [theclass "section1"] << toHtml title) @@ -800,7 +800,7 @@ ppDocGroup lev doc | lev == 3 = tda [ theclass "section3" ] << doc | otherwise = tda [ theclass "section4" ] << doc -declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (HsDoc DocName) -> Html -> HtmlTable +declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> HtmlTable declWithDoc True _ _ _ _ html_decl = declBox html_decl declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl declWithDoc False links loc nm (Just doc) html_decl = @@ -928,7 +928,7 @@ ppTyFamHeader summary associated decl unicode = Nothing -> empty -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppTyFam summary associated links loc mbDoc decl unicode @@ -985,7 +985,7 @@ ppDataInst = undefined -------------------------------------------------------------------------------- -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppTyInst summary associated links loc mbDoc decl unicode @@ -1151,7 +1151,7 @@ ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortC ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan - -> Maybe (HsDoc DocName) -> [(DocName, DocForDecl DocName)] + -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> HtmlTable ppClassDecl summary links instances loc mbDoc subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode @@ -1258,7 +1258,7 @@ ppShortDataDecl summary links loc dataDecl unicode ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode | summary = declWithDoc summary links loc docname mbDoc @@ -1738,13 +1738,13 @@ htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc -- If the doc is a single paragraph, don't surround it with

(this causes -- ugly extra whitespace with some browsers). -docToHtml :: HsDoc DocName -> Html +docToHtml :: Doc DocName -> Html docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) -origDocToHtml :: HsDoc Name -> Html +origDocToHtml :: Doc Name -> Html origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) -rdrDocToHtml :: HsDoc RdrName -> Html +rdrDocToHtml :: Doc RdrName -> Html rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) -- If there is a single paragraph, then surrounding it with

..

@@ -1752,13 +1752,13 @@ rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) -- we have multiple paragraphs, then we want the extra whitespace to -- separate them. So we catch the single paragraph case and transform it -- here. -unParagraph :: HsDoc a -> HsDoc a +unParagraph :: Doc a -> Doc a unParagraph (DocParagraph d) = d --NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) --unParagraph (DocCodeBlock d) = (DocMonospaced d) unParagraph doc = doc -htmlCleanup :: DocMarkup a (HsDoc a) +htmlCleanup :: DocMarkup a (Doc a) htmlCleanup = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, markupOrderedList = DocOrderedList . map unParagraph @@ -1894,7 +1894,7 @@ ndocBox html = tda [theclass "ndoc"] << html rdocBox :: Html -> HtmlTable rdocBox html = tda [theclass "rdoc"] << html -maybeRDocBox :: Maybe (HsDoc DocName) -> HtmlTable +maybeRDocBox :: Maybe (Doc DocName) -> HtmlTable maybeRDocBox Nothing = rdocBox (noHtml) maybeRDocBox (Just doc) = rdocBox (docToHtml doc) diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs new file mode 100644 index 00000000..adafc8fd --- /dev/null +++ b/src/Haddock/Doc.hs @@ -0,0 +1,64 @@ +module Haddock.Doc ( + docAppend, + docParagraph + ) where + + +import Haddock.Types +import Data.Char (isSpace) + + +-- used to make parsing easier; we group the list items later +docAppend :: Doc id -> Doc id -> Doc id +docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) + = DocUnorderedList (ds1++ds2) +docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) + = DocAppend (DocUnorderedList (ds1++ds2)) d +docAppend (DocOrderedList ds1) (DocOrderedList ds2) + = DocOrderedList (ds1++ds2) +docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) + = DocAppend (DocOrderedList (ds1++ds2)) d +docAppend (DocDefList ds1) (DocDefList ds2) + = DocDefList (ds1++ds2) +docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) + = DocAppend (DocDefList (ds1++ds2)) d +docAppend DocEmpty d = d +docAppend d DocEmpty = d +docAppend d1 d2 + = DocAppend d1 d2 + +-- again to make parsing easier - we spot a paragraph whose only item +-- is a DocMonospaced and make it into a DocCodeBlock +docParagraph :: Doc id -> Doc id +docParagraph (DocMonospaced p) + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocString s1) (DocMonospaced p)) + | all isSpace s1 + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocString s1) + (DocAppend (DocMonospaced p) (DocString s2))) + | all isSpace s1 && all isSpace s2 + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocMonospaced p) (DocString s2)) + | all isSpace s2 + = DocCodeBlock (docCodeBlock p) +docParagraph p + = DocParagraph p + + +-- Drop trailing whitespace from @..@ code blocks. Otherwise this: +-- +-- -- @ +-- -- foo +-- -- @ +-- +-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML +-- gives an extra vertical space after the code block. The single space +-- on the final line seems to trigger the extra vertical space. +-- +docCodeBlock :: Doc id -> Doc id +docCodeBlock (DocString s) + = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) +docCodeBlock (DocAppend l r) + = DocAppend l (docCodeBlock r) +docCodeBlock d = d diff --git a/src/Haddock/HsDoc.hs b/src/Haddock/HsDoc.hs deleted file mode 100644 index bb355a26..00000000 --- a/src/Haddock/HsDoc.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Haddock.HsDoc ( - docAppend, - docParagraph - ) where - - -import Haddock.Types -import Data.Char (isSpace) - - --- used to make parsing easier; we group the list items later -docAppend :: HsDoc id -> HsDoc id -> HsDoc id -docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) - = DocUnorderedList (ds1++ds2) -docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) - = DocAppend (DocUnorderedList (ds1++ds2)) d -docAppend (DocOrderedList ds1) (DocOrderedList ds2) - = DocOrderedList (ds1++ds2) -docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) - = DocAppend (DocOrderedList (ds1++ds2)) d -docAppend (DocDefList ds1) (DocDefList ds2) - = DocDefList (ds1++ds2) -docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) - = DocAppend (DocDefList (ds1++ds2)) d -docAppend DocEmpty d = d -docAppend d DocEmpty = d -docAppend d1 d2 - = DocAppend d1 d2 - --- again to make parsing easier - we spot a paragraph whose only item --- is a DocMonospaced and make it into a DocCodeBlock -docParagraph :: HsDoc id -> HsDoc id -docParagraph (DocMonospaced p) - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocString s1) (DocMonospaced p)) - | all isSpace s1 - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocString s1) - (DocAppend (DocMonospaced p) (DocString s2))) - | all isSpace s1 && all isSpace s2 - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocMonospaced p) (DocString s2)) - | all isSpace s2 - = DocCodeBlock (docCodeBlock p) -docParagraph p - = DocParagraph p - - --- Drop trailing whitespace from @..@ code blocks. Otherwise this: --- --- -- @ --- -- foo --- -- @ --- --- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML --- gives an extra vertical space after the code block. The single space --- on the final line seems to trigger the extra vertical space. --- -docCodeBlock :: HsDoc id -> HsDoc id -docCodeBlock (DocString s) - = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) -docCodeBlock (DocAppend l r) - = DocAppend l (docCodeBlock r) -docCodeBlock d = d diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index b6d988dc..abc5f053 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -56,7 +56,7 @@ attachInstances ifaces instIfaceMap = mapM attach ifaces attachExport export = return export -lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (HsDoc Name) +lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (Doc Name) -- TODO: capture this pattern in a function (when we have streamlined the -- handling of instances) lookupInstDoc name iface ifaceMap = diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index dc7744c7..fc44cedf 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -23,7 +23,7 @@ import Haddock.Interface.Lex import Haddock.Interface.Parse import Haddock.Interface.Rn import Haddock.Interface.ParseModuleHeader -import Haddock.HsDoc +import Haddock.Doc import Data.Maybe import FastString import GHC @@ -31,7 +31,7 @@ import RdrName data HaddockCommentType = NormalHaddockComment | DocSectionComment -lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (HsDoc Name)) +lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockCommentList hty gre docStrs = do docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs let docs = catMaybes docMbs @@ -41,7 +41,7 @@ lexParseRnHaddockCommentList hty gre docStrs = do _ -> return (Just doc) lexParseRnHaddockComment :: HaddockCommentType -> - GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (HsDoc Name)) + GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockComment hty gre (HsDocString fs) = do let str = unpackFS fs let toks = tokenise str @@ -52,14 +52,14 @@ lexParseRnHaddockComment hty gre (HsDocString fs) = do Nothing -> do tell ["doc comment parse failed: "++str] return Nothing - Just doc -> return (Just (rnHsDoc gre doc)) + Just doc -> return (Just (rnDoc gre doc)) -lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (HsDoc Name)) +lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnMbHaddockComment _ _ Nothing = return Nothing lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d -- yes, you always get a HaddockModInfo though it might be empty -lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (HsDoc Name)) +lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader gre mbStr = do let failure = (emptyHaddockModInfo, Nothing) case mbStr of @@ -71,4 +71,4 @@ lexParseRnHaddockModHeader gre mbStr = do tell ["haddock module header parse failed: " ++ mess] return failure Right (info, doc) -> - return (rnHaddockModInfo gre info, Just (rnHsDoc gre doc)) + return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) diff --git a/src/Haddock/Interface/Parse.y b/src/Haddock/Interface/Parse.y index f420c8e4..a5175ddc 100644 --- a/src/Haddock/Interface/Parse.y +++ b/src/Haddock/Interface/Parse.y @@ -12,8 +12,8 @@ module Haddock.Interface.Parse ( ) where import Haddock.Interface.Lex -import Haddock.Types (HsDoc(..)) -import Haddock.HsDoc +import Haddock.Types (Doc(..)) +import Haddock.Doc import HsSyn import RdrName } @@ -45,49 +45,49 @@ import RdrName %% -doc :: { HsDoc RdrName } +doc :: { Doc RdrName } : apara PARA doc { docAppend $1 $3 } | PARA doc { $2 } | apara { $1 } | {- empty -} { DocEmpty } -apara :: { HsDoc RdrName } +apara :: { Doc RdrName } : ulpara { DocUnorderedList [$1] } | olpara { DocOrderedList [$1] } | defpara { DocDefList [$1] } | para { $1 } -ulpara :: { HsDoc RdrName } +ulpara :: { Doc RdrName } : '-' para { $2 } -olpara :: { HsDoc RdrName } +olpara :: { Doc RdrName } : '(n)' para { $2 } -defpara :: { (HsDoc RdrName, HsDoc RdrName) } +defpara :: { (Doc RdrName, Doc RdrName) } : '[' seq ']' seq { ($2, $4) } -para :: { HsDoc RdrName } +para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } -codepara :: { HsDoc RdrName } +codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } -seq :: { HsDoc RdrName } +seq :: { Doc RdrName } : elem seq { docAppend $1 $2 } | elem { $1 } -elem :: { HsDoc RdrName } +elem :: { Doc RdrName } : elem1 { $1 } | '@' seq1 '@' { DocMonospaced $2 } -seq1 :: { HsDoc RdrName } +seq1 :: { Doc RdrName } : PARA seq1 { docAppend (DocString "\n") $2 } | elem1 seq1 { docAppend $1 $2 } | elem1 { $1 } -elem1 :: { HsDoc RdrName } +elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } | URL { DocURL $1 } diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index eb563656..e74a0aef 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -26,7 +26,7 @@ import Data.Char -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, HsDoc RdrName) +parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, Doc RdrName) parseModuleHeader str0 = let getKey :: String -> String -> (Maybe String,String) @@ -43,7 +43,7 @@ parseModuleHeader str0 = (stabilityOpt,str7) = getKey "Stability" str6 (portabilityOpt,str8) = getKey "Portability" str7 - description1 :: Either String (Maybe (HsDoc RdrName)) + description1 :: Either String (Maybe (Doc RdrName)) description1 = case descriptionOpt of Nothing -> Right Nothing Just description -> case parseHaddockString . tokenise $ description of diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 0d678537..80dc7d14 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -146,14 +146,14 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] renameExportItems = mapM renameExportItem -renameDocForDecl :: (Maybe (HsDoc Name), FnArgsDoc Name) -> RnM (Maybe (HsDoc DocName), FnArgsDoc DocName) +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') -renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName)) +renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName)) renameMaybeDoc = mapM renameDoc @@ -161,7 +161,7 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return -renameDoc :: HsDoc Name -> RnM (HsDoc DocName) +renameDoc :: Doc Name -> RnM (Doc DocName) renameDoc d = case d of DocEmpty -> return DocEmpty DocAppend a b -> do diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs index c45b5042..5127e49b 100644 --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -1,5 +1,5 @@ -module Haddock.Interface.Rn ( rnHsDoc, rnHaddockModInfo ) where +module Haddock.Interface.Rn ( rnDoc, rnHaddockModInfo ) where import Haddock.Types @@ -11,7 +11,7 @@ import Outputable ( ppr, defaultUserStyle ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name rnHaddockModInfo gre (HaddockModInfo desc port stab maint) = - HaddockModInfo (fmap (rnHsDoc gre) desc) port stab maint + HaddockModInfo (fmap (rnDoc gre) desc) port stab maint ids2string :: [RdrName] -> String ids2string [] = [] @@ -20,8 +20,8 @@ ids2string (x:_) = show $ ppr x defaultUserStyle data Id x = Id {unId::x} instance Monad Id where (Id v)>>=f = f v; return = Id -rnHsDoc :: GlobalRdrEnv -> HsDoc RdrName -> HsDoc Name -rnHsDoc gre = unId . do_rn +rnDoc :: GlobalRdrEnv -> Doc RdrName -> Doc Name +rnDoc gre = unId . do_rn where do_rn doc_to_rn = case doc_to_rn of diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index cfcc8fbd..eed44714 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -372,7 +372,7 @@ instance Binary DocOption where {-* Generated by DrIFT : Look, but Don't Touch. *-} -instance (Binary id) => Binary (HsDoc id) where +instance (Binary id) => Binary (Doc id) where put_ bh DocEmpty = do putByte bh 0 put_ bh (DocAppend aa ab) = do diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs index d82c53a6..855c00dd 100644 --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -12,15 +12,15 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.Types ( HsDoc ) +import Haddock.Types ( Doc ) import GHC ( Name ) import Module ( Module, moduleNameString, moduleName, modulePackageId, packageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree] +data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] -mkModuleTree :: Bool -> [(Module, Maybe (HsDoc Name))] -> [ModuleTree] +mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] mkModuleTree showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where @@ -28,7 +28,7 @@ mkModuleTree showPkgs mods = | otherwise = Nothing fn (mod_,pkg,short) = addToTrees mod_ pkg short -addToTrees :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree] addToTrees [] _ _ ts = ts addToTrees ss pkg short [] = mkSubTree ss pkg short addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) @@ -39,7 +39,7 @@ addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) this_pkg = if null ss then pkg else node_pkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (HsDoc Name) -> [ModuleTree] +mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] mkSubTree [] _ _ = [] mkSubTree [s] pkg short = [Node s True pkg short []] mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 86e4cea2..b4853379 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -35,15 +35,14 @@ import Test.QuickCheck -- convenient short-hands type Decl = LHsDecl Name -type Doc = HsDoc Name -type DocInstance name = (InstHead name, Maybe (HsDoc name)) +type DocInstance name = (InstHead name, Maybe (Doc name)) -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. -type FnArgsDoc name = Map Int (HsDoc name) -type DocForDecl name = (Maybe (HsDoc name), FnArgsDoc name) +type FnArgsDoc name = Map Int (Doc name) +type DocForDecl name = (Maybe (Doc name), FnArgsDoc name) noDocForDecl :: DocForDecl name noDocForDecl = (Nothing, Map.empty) @@ -117,11 +116,11 @@ data ExportItem name expItemSectionId :: String, -- | Section heading text - expItemSectionText :: HsDoc name + expItemSectionText :: Doc name } -- ^ A section heading - | ExportDoc (HsDoc name) -- ^ Some documentation + | ExportDoc (Doc name) -- ^ Some documentation | ExportModule Module -- ^ A cross-reference to another module @@ -133,7 +132,7 @@ type InstHead name = ([HsPred name], name, [HsType name]) type ModuleMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface -type DocMap = Map Name (HsDoc DocName) +type DocMap = Map Name (Doc DocName) type LinkEnv = Map Name Module @@ -172,10 +171,10 @@ data Interface = Interface { ifaceInfo :: !(HaddockModInfo Name), -- | The documentation header for this module - ifaceDoc :: !(Maybe (HsDoc Name)), + ifaceDoc :: !(Maybe (Doc Name)), -- | The renamed documentation header for this module - ifaceRnDoc :: Maybe (HsDoc DocName), + ifaceRnDoc :: Maybe (Doc DocName), -- | The Haddock options for this module (prune, ignore-exports, etc) ifaceOptions :: ![DocOption], @@ -215,7 +214,7 @@ data Interface = Interface { ifaceInstances :: ![Instance], -- | Docs for instances defined in this module - ifaceInstanceDocMap :: Map Name (HsDoc Name) + ifaceInstanceDocMap :: Map Name (Doc Name) } @@ -266,26 +265,26 @@ toInstalledIface interface = InstalledInterface { instSubMap = ifaceSubMap interface } -unrenameHsDoc :: HsDoc DocName -> HsDoc Name -unrenameHsDoc = fmap getName +unrenameDoc :: Doc DocName -> Doc Name +unrenameDoc = fmap getName unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name unrenameDocForDecl (mbDoc, fnArgsDoc) = - (fmap unrenameHsDoc mbDoc, fmap unrenameHsDoc fnArgsDoc) + (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc) -data HsDoc id +data Doc id = DocEmpty - | DocAppend (HsDoc id) (HsDoc id) + | DocAppend (Doc id) (Doc id) | DocString String - | DocParagraph (HsDoc id) + | DocParagraph (Doc id) | DocIdentifier [id] | DocModule String - | DocEmphasis (HsDoc id) - | DocMonospaced (HsDoc id) - | DocUnorderedList [HsDoc id] - | DocOrderedList [HsDoc id] - | DocDefList [(HsDoc id, HsDoc id)] - | DocCodeBlock (HsDoc id) + | DocEmphasis (Doc id) + | DocMonospaced (Doc id) + | DocUnorderedList [Doc id] + | DocOrderedList [Doc id] + | DocDefList [(Doc id, Doc id)] + | DocCodeBlock (Doc id) | DocURL String | DocPic String | DocAName String @@ -294,7 +293,7 @@ data HsDoc id #ifdef TEST -- TODO: use derive -instance Arbitrary a => Arbitrary (HsDoc a) where +instance Arbitrary a => Arbitrary (Doc a) where arbitrary = oneof [ return DocEmpty , do { a <- arbitrary; b <- arbitrary; return (DocAppend a b) } @@ -314,7 +313,7 @@ instance Arbitrary a => Arbitrary (HsDoc a) where #endif -type LHsDoc id = Located (HsDoc id) +type LDoc id = Located (Doc id) data DocMarkup id a = Markup { @@ -337,7 +336,7 @@ data DocMarkup id a = Markup { data HaddockModInfo name = HaddockModInfo { - hmi_description :: Maybe (HsDoc name), + hmi_description :: Maybe (Doc name), hmi_portability :: Maybe String, hmi_stability :: Maybe String, hmi_maintainer :: Maybe String diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 6a30cb07..da144355 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -33,7 +33,7 @@ module Haddock.Utils ( -- * HTML cross reference mapping html_xrefs_ref, - -- * HsDoc markup + -- * Doc markup markup, idMarkup, @@ -102,11 +102,11 @@ out progVerbosity msgVerbosity msg -- | extract a module's short description. -toDescription :: Interface -> Maybe (HsDoc Name) +toDescription :: Interface -> Maybe (Doc Name) toDescription = hmi_description . ifaceInfo -- | extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (HsDoc Name) +toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) toInstalledDescription = hmi_description . instInfo @@ -311,7 +311,7 @@ replace a b = map (\x -> if x == a then b else x) ----------------------------------------------------------------------------- -- put here temporarily -markup :: DocMarkup id a -> HsDoc id -> a +markup :: DocMarkup id a -> Doc id -> a markup m DocEmpty = markupEmpty m markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) markup m (DocString s) = markupString m s @@ -328,11 +328,11 @@ markup m (DocURL url) = markupURL m url markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img -markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a) +markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) -- | The identity markup -idMarkup :: DocMarkup a (HsDoc a) +idMarkup :: DocMarkup a (Doc a) idMarkup = Markup { markupEmpty = DocEmpty, markupString = DocString, -- cgit v1.2.3