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
|
-----------------------------------------------------------------------------
-- |
-- 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
( processDocString
, processDocStringParas
, processDocStrings
, processModuleHeader
) where
import Haddock.Types
import Haddock.Lex
import Haddock.Parse
import Haddock.Interface.ParseModuleHeader
import Haddock.Doc
import Control.Applicative
import Data.List
import Data.Maybe
import FastString
import GHC
import Name
import Outputable
import RdrName
import RnEnv
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
processDocStrings dflags gre strs = do
docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
let doc = foldl' docAppend DocEmpty docs
case doc of
DocEmpty -> return Nothing
_ -> return (Just doc)
processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
processDocStringParas = process parseParas
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
processDocString = process parseString
process :: ([LToken] -> Maybe (Doc RdrName))
-> DynFlags
-> GlobalRdrEnv
-> HsDocString
-> ErrMsgM (Maybe (Doc Name))
process parse dflags gre (HsDocString fs) = do
let str = unpackFS fs
let toks = tokenise dflags str (0,0) -- TODO: real position
case parse toks of
Nothing -> do
tell [ "doc comment parse failed: " ++ str ]
return Nothing
Just doc -> return (Just (rename gre doc))
processModuleHeader :: DynFlags -> GlobalRdrEnv -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
processModuleHeader dflags gre mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
case parseModuleHeader dflags str of
Left msg -> do
tell ["haddock module header parse failed: " ++ msg]
return failure
Right (hmi, doc) -> do
let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi }
doc' = rename gre doc
return (hmi', Just doc')
let safety = Just $ showPpr $ safeHaskell dflags
return (hmi { hmi_safety = safety }, doc)
where
failure = (emptyHaddockModInfo, Nothing)
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.
DocWarning doc -> DocWarning (rn doc)
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))
|
