2 module HaddockUtils where
5 import {-# SOURCE #-} HaddockLex
13 -- -----------------------------------------------------------------------------
14 -- Parsing module headers
16 -- NB. The headers must be given in the order Module, Description,
17 -- Copyright, License, Maintainer, Stability, Portability, except that
18 -- any or all may be omitted.
19 parseModuleHeader :: String -> Either String (String, HaddockModInfo RdrName)
20 parseModuleHeader str0 =
22 getKey :: String -> String -> (Maybe String,String)
23 getKey key str = case parseKey key str of
24 Nothing -> (Nothing,str)
25 Just (value,rest) -> (Just value,rest)
27 (_moduleOpt,str1) = getKey "Module" str0
28 (descriptionOpt,str2) = getKey "Description" str1
29 (_copyrightOpt,str3) = getKey "Copyright" str2
30 (_licenseOpt,str4) = getKey "License" str3
31 (_licenceOpt,str5) = getKey "Licence" str4
32 (maintainerOpt,str6) = getKey "Maintainer" str5
33 (stabilityOpt,str7) = getKey "Stability" str6
34 (portabilityOpt,str8) = getKey "Portability" str7
36 description1 :: Either String (Maybe (HsDoc RdrName))
37 description1 = case descriptionOpt of
38 Nothing -> Right Nothing
39 Just description -> case parseHaddockString . tokenise $ description of
41 MyLeft mess -> Left ("Cannot parse Description: " ++ mess)
42 MyRight doc -> Right (Just doc)
45 Left mess -> Left mess
46 Right docOpt -> Right (str8,HaddockModInfo {
47 hmi_description = docOpt,
48 hmi_portability = portabilityOpt,
49 hmi_stability = stabilityOpt,
50 hmi_maintainer = maintainerOpt
53 -- | This function is how we read keys.
55 -- all fields in the header are optional and have the form
57 -- [spaces1][field name][spaces] ":"
58 -- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
59 -- where each [spaces2] should have [spaces1] as a prefix.
61 -- Thus for the key "Description",
63 -- > Description : this is a
68 -- > The module comment starts here
70 -- the value will be "this is a .. description" and the rest will begin
71 -- at "The module comment".
72 parseKey :: String -> String -> Maybe (String,String)
73 parseKey key toParse0 =
76 (spaces0,toParse1) = extractLeadingSpaces toParse0
79 afterKey0 <- extractPrefix key toParse1
81 afterKey1 = extractLeadingSpaces afterKey0
82 afterColon0 <- case snd afterKey1 of
83 ':':afterColon -> return afterColon
86 (_,afterColon1) = extractLeadingSpaces afterColon0
88 return (scanKey True indentation afterColon1)
90 scanKey :: Bool -> String -> String -> (String,String)
91 scanKey _ _ [] = ([],[])
92 scanKey isFirst indentation str =
94 (nextLine,rest1) = extractNextLine str
96 accept = isFirst || sufficientIndentation || allSpaces
98 sufficientIndentation = case extractPrefix indentation nextLine of
99 Just (c:_) | isSpace c -> True
102 allSpaces = case extractLeadingSpaces nextLine of
109 (scanned1,rest2) = scanKey False indentation rest1
111 scanned2 = case scanned1 of
112 "" -> if allSpaces then "" else nextLine
113 _ -> nextLine ++ "\n" ++ scanned1
119 extractLeadingSpaces :: String -> (String,String)
120 extractLeadingSpaces [] = ([],[])
121 extractLeadingSpaces (s@(c:cs))
124 (spaces1,cs1) = extractLeadingSpaces cs
129 extractNextLine :: String -> (String,String)
130 extractNextLine [] = ([],[])
131 extractNextLine (c:cs)
136 (line,rest) = extractNextLine cs
140 -- comparison is case-insensitive.
141 extractPrefix :: String -> String -> Maybe String
142 extractPrefix [] s = Just s
143 extractPrefix _ [] = Nothing
144 extractPrefix (c1:cs1) (c2:cs2)
145 | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
148 -- -----------------------------------------------------------------------------
149 -- Adding documentation to record fields (used in parsing).
151 addFieldDoc :: ConDeclField a -> Maybe (LHsDoc a) -> ConDeclField a
152 addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }
154 addFieldDocs :: [ConDeclField a] -> Maybe (LHsDoc a) -> [ConDeclField a]
155 addFieldDocs [] _ = []
156 addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
158 addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
159 addConDoc decl Nothing = decl
160 addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
162 addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
164 addConDocs [x] doc = [addConDoc x doc]
165 addConDocs (x:xs) doc = x : addConDocs xs doc
167 addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
168 addConDocFirst [] _ = []
169 addConDocFirst (x:xs) doc = addConDoc x doc : xs