diff options
Diffstat (limited to 'src/HaddockUtil.hs')
| -rw-r--r-- | src/HaddockUtil.hs | 151 |
1 files changed, 1 insertions, 150 deletions
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 1d4eb29b..92d81ff6 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -9,7 +9,7 @@ module HaddockUtil ( -- * Misc utilities nameOfQName, collectNames, declBinders, declMainBinder, declSubBinders, - splitTyConApp, restrictTo, declDoc, parseModuleHeader, freeTyCons, unbang, + splitTyConApp, restrictTo, declDoc, freeTyCons, unbang, addFieldDoc, addFieldDocs, addConDoc, addConDocs,toDescription, unQual, -- * Filename utilities @@ -26,8 +26,6 @@ module HaddockUtil ( ) where import Binary2 -import HaddockLex2 -import HaddockParse2 import HaddockTypes import HsSyn2 import Map ( Map ) @@ -229,153 +227,6 @@ declDoc (HsForeignImport _ _ _ _ _ _ d) = d declDoc _ = Nothing -- ----------------------------------------------------------------------------- --- Parsing module headers - --- NB. The headers must be given in the order Module, Description, --- Copyright, License, Maintainer, Stability, Portability, except that --- any or all may be omitted. -parseModuleHeader :: String -> Either String (String,ModuleInfo) -parseModuleHeader str0 = - let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) - - (moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (maintainerOpt,str6) = getKey "Maintainer" str5 - (stabilityOpt,str7) = getKey "Stability" str6 - (portabilityOpt,str8) = getKey "Portability" str7 - - description1 :: Either String (Maybe Doc) - description1 = case descriptionOpt of - Nothing -> Right Nothing - Just description -> case parseString . tokenise $ description of - Left mess -> Left ("Cannot parse Description: " ++ mess) - Right doc -> Right (Just doc) - in - case description1 of - Left mess -> Left mess - Right docOpt -> Right (str8,ModuleInfo { - description = docOpt, - portability = portabilityOpt, - stability = stabilityOpt, - maintainer = maintainerOpt - }) - - --- | This function is how we read keys. --- --- all fields in the header are optional and have the form --- --- [spaces1][field name][spaces] ":" --- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* --- where each [spaces2] should have [spaces1] as a prefix. --- --- Thus for the key "Description", --- --- > Description : this is a --- > rather long --- > --- > description --- > --- > The module comment starts here --- --- the value will be "this is a .. description" and the rest will begin --- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces toParse0 - - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 - - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey isFirst indentation [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str - - accept = isFirst || sufficientIndentation || allSpaces - - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False - - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 - - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) - - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | True = ([],s) - - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | True = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) - - - -- indentation returns characters after last newline. - indentation :: String -> String - indentation s = fromMaybe s (indentation0 s) - where - indentation0 :: String -> Maybe String - indentation0 [] = Nothing - indentation0 (c:cs) = - case indentation0 cs of - Nothing -> if c == '\n' then Just cs else Nothing - in0 -> in0 - - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix s [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | True = Nothing - --- ----------------------------------------------------------------------------- -- Filename mangling functions stolen from GHC's main/DriverUtil.lhs. type Suffix = String |