-{-# OPTIONS -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/Commentary/CodingStyle#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
-
- MyLeft mess -> Left ("Cannot parse Description: " ++ mess)
- MyRight 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)
-
- -- 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
projects / ghc-hetmet.git / blobdiff