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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
-- Copyright : (c) Isaac Dupree 2009,
-- Mateusz Kowalczyk 2013
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
( processDocString
, processDocStringParas
, processDocStrings
, processModuleHeader
) where
import Control.Applicative
import Data.IntSet (toList)
import Data.List
import Data.Maybe
import Data.Monoid ((<>))
import DynFlags (ExtensionFlag(..), languageExtensions)
import FastString
import GHC
import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
import Name
import Outputable (showPpr)
import RdrName
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))
processDocStrings dflags gre strs = do
docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs
let doc = foldl' (<>) DocEmpty docs
case doc of
DocEmpty -> return Nothing
_ -> return (Just doc)
processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
processDocStringParas = process parseParasMaybe
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))
processDocString = process parseStringMaybe
process :: (DynFlags -> String -> Maybe (Doc RdrName))
-> DynFlags
-> GlobalRdrEnv
-> HsDocString
-> ErrMsgM (Maybe (Doc Name))
process parse dflags gre (HsDocString fs) = do
let str = unpackFS fs
case parse dflags str of
Nothing -> do
tell [ "doc comment parse failed: " ++ str ]
return Nothing
Just doc -> do
return (Just (rename dflags gre doc))
processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
processModuleHeader dflags gre safety 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 !descr = rename dflags gre <$> hmi_description hmi
hmi' = hmi { hmi_description = descr }
doc' = rename dflags gre doc
return (hmi', Just doc')
let flags :: [ExtensionFlag]
-- We remove the flags implied by the language setting and we display the language instead
flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
} , doc)
where
failure = (emptyHaddockModInfo, Nothing)
rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags 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 (showPpr dflags x))
[a] -> outOfScope dflags a
a:b:_ | isRdrTc a -> outOfScope dflags a
| otherwise -> outOfScope dflags 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)
DocBold doc -> DocBold (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
DocHyperlink l -> DocHyperlink l
DocPic str -> DocPic str
DocAName str -> DocAName str
DocProperty p -> DocProperty p
DocExamples e -> DocExamples e
DocEmpty -> DocEmpty
DocString str -> DocString str
DocHeader (Header l t) -> DocHeader $ Header l (rn t)
dataTcOccs' :: RdrName -> [RdrName]
-- If the input is a data constructor, return both it and a type
-- constructor. This is useful when we aren't sure which we are
-- looking at.
--
-- We use this definition instead of the GHC's to provide proper linking to
-- functions accross modules. See ticket #253 on Haddock Trac.
dataTcOccs' rdr_name
| isDataOcc occ = [rdr_name, rdr_name_tc]
| otherwise = [rdr_name]
where
occ = rdrNameOcc rdr_name
rdr_name_tc = setRdrNameSpace rdr_name tcName
outOfScope :: DynFlags -> RdrName -> Doc a
outOfScope dflags 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 (showPpr dflags a))
|
