From 638683cbe3d68427273ad71eeb8f704e165952fa Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 26 Nov 2011 21:44:28 +0100 Subject: Cleanup. --- haddock.cabal | 2 - src/Haddock/Interface/LexParseRn.hs | 100 ++++++++++++++++++++++++++++-------- src/Haddock/Interface/Rn.hs | 100 ------------------------------------ 3 files changed, 79 insertions(+), 123 deletions(-) delete mode 100644 src/Haddock/Interface/Rn.hs diff --git a/haddock.cabal b/haddock.cabal index 1180cad0..81d64756 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -111,7 +111,6 @@ executable haddock Haddock.Interface.Create Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances - Haddock.Interface.Rn Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Lex @@ -175,7 +174,6 @@ library Haddock.Interface.Create Haddock.Interface.ExtractFnArgDocs Haddock.Interface.AttachInstances - Haddock.Interface.Rn Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Lex diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index d013ca27..f70c5953 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -8,28 +8,34 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Interface.LexParseRn ( - HaddockCommentType(..), - lexParseRnHaddockComment, - lexParseRnHaddockCommentList, - lexParseRnMbHaddockComment, - lexParseRnHaddockModHeader +module Haddock.Interface.LexParseRn + ( HaddockCommentType(..) + , lexParseRnHaddockComment + , lexParseRnHaddockCommentList + , lexParseRnMbHaddockComment + , lexParseRnHaddockModHeader ) where + import Haddock.Types import Haddock.Lex import Haddock.Parse -import Haddock.Interface.Rn import Haddock.Interface.ParseModuleHeader import Haddock.Doc + +import Control.Applicative import Data.Maybe import FastString import GHC -import Outputable ( showPpr ) +import Name +import Outputable import RdrName +import RnEnv + data HaddockCommentType = NormalHaddockComment | DocSectionComment + lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockCommentList dflags hty gre docStrs = do docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs @@ -39,6 +45,7 @@ lexParseRnHaddockCommentList dflags hty gre docStrs = do DocEmpty -> return Nothing _ -> return (Just doc) + lexParseRnHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do @@ -51,27 +58,78 @@ lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do Nothing -> do tell ["doc comment parse failed: "++str] return Nothing - Just doc -> return (Just (rnDoc gre doc)) + Just doc -> return (Just (rename gre doc)) + lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d + -- yes, you always get a HaddockModInfo though it might be empty lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader dflags gre mbStr = do - (hmod, docn) <- case mbStr of - Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs - case parseModuleHeader dflags str of - Left mess -> do - tell ["haddock module header parse failed: " ++ mess] - return failure - Right (info, doc) -> - return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) - return (hmod { hmi_safety = safety }, docn) - + (hmi, docn) <- + case mbStr of + Nothing -> return failure + Just (L _ (HsDocString fs)) -> do + let str = unpackFS fs + case parseModuleHeader dflags str of + Left mess -> do + tell ["haddock module header parse failed: " ++ mess] + return failure + Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc)) + return (hmi { hmi_safety = safety }, docn) where safety = Just $ showPpr $ safeHaskell dflags failure = (emptyHaddockModInfo, Nothing) + + +renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name +renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi } + + +rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name +rename gre = rn + where + rn d = case d of + DocAppend a b -> DocAppend (rn a) (rn b) + DocParagraph doc -> DocParagraph (rn doc) + DocIdentifier x -> do + let choices = dataTcOccs x + let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + case names of + [] -> + case choices of + [] -> DocMonospaced (DocString (showSDoc $ ppr x)) + [a] -> outOfScope a + a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b + [a] -> DocIdentifier a + a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b + -- If an id can refer to multiple things, we give precedence to type + -- constructors. + DocEmphasis doc -> DocEmphasis (rn doc) + DocMonospaced doc -> DocMonospaced (rn doc) + DocUnorderedList docs -> DocUnorderedList (map rn docs) + DocOrderedList docs -> DocOrderedList (map rn docs) + DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] + DocCodeBlock doc -> DocCodeBlock (rn doc) + DocIdentifierUnchecked x -> DocIdentifierUnchecked x + DocModule str -> DocModule str + DocURL str -> DocURL str + DocPic str -> DocPic str + DocAName str -> DocAName str + DocExamples e -> DocExamples e + DocEmpty -> DocEmpty + DocString str -> DocString str + + +outOfScope :: RdrName -> Doc a +outOfScope x = + case x of + Unqual occ -> monospaced occ + Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) + Orig _ occ -> monospaced occ + Exact name -> monospaced name -- Shouldn't happen since x is out of scope + where + monospaced a = DocMonospaced (DocString (showSDoc $ ppr a)) diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs deleted file mode 100644 index 0b5efe4b..00000000 --- a/src/Haddock/Interface/Rn.hs +++ /dev/null @@ -1,100 +0,0 @@ -module Haddock.Interface.Rn ( rnDoc, rnHaddockModInfo ) where - -import Haddock.Types - -import RnEnv ( dataTcOccs ) - -import RdrName -import Name ( Name, isTyConName ) -import Outputable ( ppr, showSDoc ) - -rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -rnHaddockModInfo gre hmod = - let desc = hmi_description hmod - in hmod { hmi_description = fmap (rnDoc gre) desc } - -data Id x = Id {unId::x} -instance Monad Id where (Id v)>>=f = f v; return = Id - -rnDoc :: GlobalRdrEnv -> Doc RdrName -> Doc Name -rnDoc gre = unId . do_rn - where - do_rn doc_to_rn = case doc_to_rn of - - DocEmpty -> return DocEmpty - - DocAppend a b -> do - a' <- do_rn a - b' <- do_rn b - return (DocAppend a' b') - - DocString str -> return (DocString str) - - DocParagraph doc -> do - doc' <- do_rn doc - return (DocParagraph doc') - - DocIdentifier x -> do - let choices = dataTcOccs x - let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices - return $ - case names of - [] -> - case choices of - [] -> DocMonospaced (DocString (showSDoc $ ppr x)) - [a] -> outOfScope a - a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b - [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. - - DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x) - - DocModule str -> return (DocModule str) - - DocEmphasis doc -> do - doc' <- do_rn doc - return (DocEmphasis doc') - - DocMonospaced doc -> do - doc' <- do_rn doc - return (DocMonospaced doc') - - DocUnorderedList docs -> do - docs' <- mapM do_rn docs - return (DocUnorderedList docs') - - DocOrderedList docs -> do - docs' <- mapM do_rn docs - return (DocOrderedList docs') - - DocDefList list -> do - list' <- mapM (\(a,b) -> do - a' <- do_rn a - b' <- do_rn b - return (a', b')) list - return (DocDefList list') - - DocCodeBlock doc -> do - doc' <- do_rn doc - return (DocCodeBlock doc') - - DocURL str -> return (DocURL str) - - DocPic str -> return (DocPic str) - - DocAName str -> return (DocAName str) - - DocExamples e -> return (DocExamples e) - - -outOfScope :: RdrName -> Doc a -outOfScope x = - case x of - Unqual occ -> monospaced occ - Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) - Orig _ occ -> monospaced occ - Exact name -> monospaced name -- Shouldn't happen since x is out of scope - where - monospaced a = DocMonospaced (DocString (showSDoc $ ppr a)) -- cgit v1.2.3