--- /dev/null
+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)
+
+addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field 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 } )
+
+addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [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 [] _ = []
+addConDocFirst (x:xs) doc = addConDoc x doc : xs
projects / ghc-hetmet.git / blobdiff