1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
-- Copyright : (c) Isaac Dupree 2009,
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
( HaddockCommentType(..)
, lexParseRnHaddockComment
, lexParseRnHaddockCommentList
, lexParseRnMbHaddockComment
, lexParseRnHaddockModHeader
) where
import Haddock.Types
import Haddock.Lex
import Haddock.Parse
import Haddock.Interface.ParseModuleHeader
import Haddock.Doc
import Control.Applicative
import Data.Maybe
import FastString
import GHC
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
let docs = catMaybes docMbs
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
let str = unpackFS fs
let toks = tokenise dflags str (0,0) -- TODO: real position
let parse = case hty of
NormalHaddockComment -> parseParas
DocSectionComment -> parseString
case parse toks of
Nothing -> do
tell ["doc comment parse failed: "++str]
return Nothing
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
(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))
|
