1 module HaddockUtils where
5 import {-# SOURCE #-} HaddockLex
15 -- -----------------------------------------------------------------------------
16 -- Parsing module headers
18 -- NB. The headers must be given in the order Module, Description,
19 -- Copyright, License, Maintainer, Stability, Portability, except that
20 -- any or all may be omitted.
21 parseModuleHeader :: String -> Either String (String, HaddockModInfo RdrName)
22 parseModuleHeader str0 =
24 getKey :: String -> String -> (Maybe String,String)
25 getKey key str = case parseKey key str of
26 Nothing -> (Nothing,str)
27 Just (value,rest) -> (Just value,rest)
29 (moduleOpt,str1) = getKey "Module" str0
30 (descriptionOpt,str2) = getKey "Description" str1
31 (copyrightOpt,str3) = getKey "Copyright" str2
32 (licenseOpt,str4) = getKey "License" str3
33 (licenceOpt,str5) = getKey "Licence" str4
34 (maintainerOpt,str6) = getKey "Maintainer" str5
35 (stabilityOpt,str7) = getKey "Stability" str6
36 (portabilityOpt,str8) = getKey "Portability" str7
38 description1 :: Either String (Maybe (HsDoc RdrName))
39 description1 = case descriptionOpt of
40 Nothing -> Right Nothing
41 Just description -> case parseHaddockString . tokenise $ description of
43 Left mess -> Left ("Cannot parse Description: " ++ mess)
44 Right doc -> Right (Just doc)
47 Left mess -> Left mess
48 Right docOpt -> Right (str8,HaddockModInfo {
49 hmi_description = docOpt,
50 hmi_portability = portabilityOpt,
51 hmi_stability = stabilityOpt,
52 hmi_maintainer = maintainerOpt
55 -- | This function is how we read keys.
57 -- all fields in the header are optional and have the form
59 -- [spaces1][field name][spaces] ":"
60 -- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
61 -- where each [spaces2] should have [spaces1] as a prefix.
63 -- Thus for the key "Description",
65 -- > Description : this is a
70 -- > The module comment starts here
72 -- the value will be "this is a .. description" and the rest will begin
73 -- at "The module comment".
74 parseKey :: String -> String -> Maybe (String,String)
75 parseKey key toParse0 =
78 (spaces0,toParse1) = extractLeadingSpaces toParse0
81 afterKey0 <- extractPrefix key toParse1
83 afterKey1 = extractLeadingSpaces afterKey0
84 afterColon0 <- case snd afterKey1 of
85 ':':afterColon -> return afterColon
88 (_,afterColon1) = extractLeadingSpaces afterColon0
90 return (scanKey True indentation afterColon1)
92 scanKey :: Bool -> String -> String -> (String,String)
93 scanKey isFirst indentation [] = ([],[])
94 scanKey isFirst indentation str =
96 (nextLine,rest1) = extractNextLine str
98 accept = isFirst || sufficientIndentation || allSpaces
100 sufficientIndentation = case extractPrefix indentation nextLine of
101 Just (c:_) | isSpace c -> True
104 allSpaces = case extractLeadingSpaces nextLine of
111 (scanned1,rest2) = scanKey False indentation rest1
113 scanned2 = case scanned1 of
114 "" -> if allSpaces then "" else nextLine
115 _ -> nextLine ++ "\n" ++ scanned1
121 extractLeadingSpaces :: String -> (String,String)
122 extractLeadingSpaces [] = ([],[])
123 extractLeadingSpaces (s@(c:cs))
126 (spaces1,cs1) = extractLeadingSpaces cs
131 extractNextLine :: String -> (String,String)
132 extractNextLine [] = ([],[])
133 extractNextLine (c:cs)
138 (line,rest) = extractNextLine cs
143 -- indentation returns characters after last newline.
144 indentation :: String -> String
145 indentation s = fromMaybe s (indentation0 s)
147 indentation0 :: String -> Maybe String
148 indentation0 [] = Nothing
149 indentation0 (c:cs) =
150 case indentation0 cs of
151 Nothing -> if c == '\n' then Just cs else Nothing
154 -- comparison is case-insensitive.
155 extractPrefix :: String -> String -> Maybe String
156 extractPrefix [] s = Just s
157 extractPrefix s [] = Nothing
158 extractPrefix (c1:cs1) (c2:cs2)
159 | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
162 -- -----------------------------------------------------------------------------
163 -- Adding documentation to record fields (used in parsing).
165 type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
167 addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
168 addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
170 addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
171 addFieldDocs [] _ = []
172 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
174 addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
175 addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
177 addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
179 addConDocs [x] doc = [addConDoc x doc]
180 addConDocs (x:xs) doc = x : addConDocs xs doc
182 addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
183 addConDocFirst [] _ = []
184 addConDocFirst (x:xs) doc = addConDoc x doc : xs