X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FHaddockUtils.hs;h=bf22cd77c10b026ac6dee1c1ace8d41b010a3c9f;hp=a0c83866babc9ab50a1a9fede1daa81bfdd44285;hb=4ac2bb39dffb4b825ece73b349ff0d56d79092d7;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index a0c8386..bf22cd7 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -1,191 +1,30 @@ -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details module HaddockUtils where import HsSyn -import HsDoc -import {-# SOURCE #-} HaddockLex -import HaddockParse import SrcLoc -import RdrName import Control.Monad -import Data.Maybe -import Data.Char -import Data.Either - --- ----------------------------------------------------------------------------- --- 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, HaddockModInfo RdrName) -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 (HsDoc RdrName)) - description1 = case descriptionOpt of - Nothing -> Right Nothing - Just description -> case parseHaddockString . 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,HaddockModInfo { - hmi_description = docOpt, - hmi_portability = portabilityOpt, - hmi_stability = stabilityOpt, - hmi_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 -- ----------------------------------------------------------------------------- -- Adding documentation to record fields (used in parsing). -type Field a = ([Located a], LBangType a, Maybe (LHsDoc a)) - -addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a -addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc) +addFieldDoc :: ConDeclField a -> Maybe LHsDocString -> ConDeclField a +addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc } -addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a] +addFieldDocs :: [ConDeclField a] -> Maybe LHsDocString -> [ConDeclField a] addFieldDocs [] _ = [] addFieldDocs (x:xs) doc = addFieldDoc x doc : xs -addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a -addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) +addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a +addConDoc decl Nothing = decl +addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) -addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a] +addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] addConDocs [] _ = [] addConDocs [x] doc = [addConDoc x doc] addConDocs (x:xs) doc = x : addConDocs xs doc -addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a] +addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] addConDocFirst [] _ = [] addConDocFirst (x:xs) doc = addConDoc x doc : xs