aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock.cabal2
-rw-r--r--src/Haddock/Interface/LexParseRn.hs100
-rw-r--r--src/Haddock/Interface/Rn.hs100
3 files changed, 79 insertions, 123 deletions
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))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 23:22:28 +0000