2 module HaddockUtils where
6 import {-# SOURCE #-} HaddockLex
16 -- -----------------------------------------------------------------------------
17 -- Parsing module headers
19 -- NB. The headers must be given in the order Module, Description,
20 -- Copyright, License, Maintainer, Stability, Portability, except that
21 -- any or all may be omitted.
22 parseModuleHeader :: String -> Either String (String, HaddockModInfo RdrName)
23 parseModuleHeader str0 =
25 getKey :: String -> String -> (Maybe String,String)
26 getKey key str = case parseKey key str of
27 Nothing -> (Nothing,str)
28 Just (value,rest) -> (Just value,rest)
30 (_moduleOpt,str1) = getKey "Module" str0
31 (descriptionOpt,str2) = getKey "Description" str1
32 (_copyrightOpt,str3) = getKey "Copyright" str2
33 (_licenseOpt,str4) = getKey "License" str3
34 (_licenceOpt,str5) = getKey "Licence" str4
35 (maintainerOpt,str6) = getKey "Maintainer" str5
36 (stabilityOpt,str7) = getKey "Stability" str6
37 (portabilityOpt,str8) = getKey "Portability" str7
39 description1 :: Either String (Maybe (HsDoc RdrName))
40 description1 = case descriptionOpt of
41 Nothing -> Right Nothing
42 Just description -> case parseHaddockString . tokenise $ description of
44 MyLeft mess -> Left ("Cannot parse Description: " ++ mess)
45 MyRight doc -> Right (Just doc)
48 Left mess -> Left mess
49 Right docOpt -> Right (str8,HaddockModInfo {
50 hmi_description = docOpt,
51 hmi_portability = portabilityOpt,
52 hmi_stability = stabilityOpt,
53 hmi_maintainer = maintainerOpt
56 -- | This function is how we read keys.
58 -- all fields in the header are optional and have the form
60 -- [spaces1][field name][spaces] ":"
61 -- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
62 -- where each [spaces2] should have [spaces1] as a prefix.
64 -- Thus for the key "Description",
66 -- > Description : this is a
71 -- > The module comment starts here
73 -- the value will be "this is a .. description" and the rest will begin
74 -- at "The module comment".
75 parseKey :: String -> String -> Maybe (String,String)
76 parseKey key toParse0 =
79 (spaces0,toParse1) = extractLeadingSpaces toParse0
82 afterKey0 <- extractPrefix key toParse1
84 afterKey1 = extractLeadingSpaces afterKey0
85 afterColon0 <- case snd afterKey1 of
86 ':':afterColon -> return afterColon
89 (_,afterColon1) = extractLeadingSpaces afterColon0
91 return (scanKey True indentation afterColon1)
93 scanKey :: Bool -> String -> String -> (String,String)
94 scanKey _ _ [] = ([],[])
95 scanKey isFirst indentation str =
97 (nextLine,rest1) = extractNextLine str
99 accept = isFirst || sufficientIndentation || allSpaces
101 sufficientIndentation = case extractPrefix indentation nextLine of
102 Just (c:_) | isSpace c -> True
105 allSpaces = case extractLeadingSpaces nextLine of
112 (scanned1,rest2) = scanKey False indentation rest1
114 scanned2 = case scanned1 of
115 "" -> if allSpaces then "" else nextLine
116 _ -> nextLine ++ "\n" ++ scanned1
122 extractLeadingSpaces :: String -> (String,String)
123 extractLeadingSpaces [] = ([],[])
124 extractLeadingSpaces (s@(c:cs))
127 (spaces1,cs1) = extractLeadingSpaces cs
132 extractNextLine :: String -> (String,String)
133 extractNextLine [] = ([],[])
134 extractNextLine (c:cs)
139 (line,rest) = extractNextLine cs
143 -- comparison is case-insensitive.
144 extractPrefix :: String -> String -> Maybe String
145 extractPrefix [] s = Just s
146 extractPrefix _ [] = Nothing
147 extractPrefix (c1:cs1) (c2:cs2)
148 | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
151 -- -----------------------------------------------------------------------------
152 -- Adding documentation to record fields (used in parsing).
154 type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
156 addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
157 addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
159 addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
160 addFieldDocs [] _ = []
161 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
163 addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
164 addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
166 addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
168 addConDocs [x] doc = [addConDoc x doc]
169 addConDocs (x:xs) doc = x : addConDocs xs doc
171 addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
172 addConDocFirst [] _ = []
173 addConDocFirst (x:xs) doc = addConDoc x doc : xs