aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/Create.hs140
-rw-r--r--src/Haddock/Interface/Lex.x171
-rw-r--r--src/Haddock/Interface/LexParseRn.hs89
-rw-r--r--src/Haddock/Interface/Parse.y106
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs158
-rw-r--r--src/Haddock/Interface/Rename.hs13
-rw-r--r--src/Haddock/Interface/Rn.hs82
7 files changed, 710 insertions, 49 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 62960360..41028100 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -18,6 +18,7 @@ import Haddock.Options
import Haddock.GhcUtils
import Haddock.Utils
import Haddock.Convert
+import Haddock.Interface.LexParseRn
import qualified Data.Map as Map
import Data.Map (Map)
@@ -29,6 +30,7 @@ import Control.Monad
import GHC hiding (flags)
import Name
import Bag
+import RdrName (GlobalRdrEnv)
-- | Process the data in the GhcModule to produce an interface.
@@ -40,24 +42,29 @@ createInterface ghcMod flags modMap instIfaceMap = do
let mdl = ghcModule ghcMod
+ -- The pattern-match should not fail, because createInterface is only
+ -- done on loaded modules.
+ Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl)
+
opts0 <- liftErrMsg $ mkDocOpts (ghcMbDocOpts ghcMod) flags mdl
let opts
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
- let group_ = ghcGroup ghcMod
+ (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader
+ gre (ghcMbDocHdr ghcMod)
+ decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod))
+ let decls = filterOutInstances decls0
+ declMap = mkDeclMap decls
exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)
localNames = ghcDefinedNames ghcMod
- decls0 = declInfos . topDecls $ group_
- decls = filterOutInstances decls0
- declMap = mkDeclMap decls
ignoreExps = Flag_IgnoreAllExports `elem` flags
exportedNames = ghcExportedNames ghcMod
instances = ghcInstances ghcMod
liftErrMsg $ warnAboutFilteredDecls mdl decls0
- exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap
+ exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap
opts exports ignoreExps instances instIfaceMap
let visibleNames = mkVisibleNames exportItems opts
@@ -72,8 +79,8 @@ createInterface ghcMod flags modMap instIfaceMap = do
return Interface {
ifaceMod = mdl,
ifaceOrigFilename = ghcFilename ghcMod,
- ifaceInfo = ghcHaddockModInfo ghcMod,
- ifaceDoc = ghcMbDoc ghcMod,
+ ifaceInfo = info,
+ ifaceDoc = mbDoc,
ifaceRnDoc = Nothing,
ifaceOptions = opts,
ifaceLocals = localNames,
@@ -139,17 +146,27 @@ mkDeclMap decls = Map.fromList . concat $
, not (isDocD d), not (isInstD d) ]
-declInfos :: [(Decl, Maybe Doc)] -> [DeclInfo]
-declInfos decls = [ (parent, doc, subordinates d)
- | (parent@(L _ d), doc) <- decls]
+declInfos :: GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
+declInfos gre decls =
+ forM decls $ \(parent@(L _ d), mbDocString) -> do
+ mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+ gre mbDocString
+ let subsStringy = subordinates d
+ subs <- forM subsStringy $ \(subName, mbSubDocString) -> do
+ mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+ gre mbSubDocString
+ return (subName, mbSubDoc)
-subordinates :: HsDecl Name -> [(Name, Maybe Doc)]
+ return (parent, mbDoc, subs)
+
+
+subordinates :: HsDecl Name -> [(Name, MaybeDocStrings)]
subordinates (TyClD d) = classDataSubs d
subordinates _ = []
-classDataSubs :: TyClDecl Name -> [(Name, Maybe Doc)]
+classDataSubs :: TyClDecl Name -> [(Name, MaybeDocStrings)]
classDataSubs decl
| isClassDecl decl = classSubs
| isDataDecl decl = dataSubs
@@ -159,15 +176,16 @@ classDataSubs decl
dataSubs = constrs ++ fields
where
cons = map unL $ tcdCons decl
- constrs = [ (unL $ con_name c, fmap unL $ con_doc c) | c <- cons ]
- fields = [ (unL n, fmap unL doc)
+ constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c)
+ | c <- cons ]
+ fields = [ (unL n, maybeToList $ fmap unL doc)
| RecCon flds <- map con_details cons
, ConDeclField n _ doc <- flds ]
-- All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
-classDecls :: TyClDecl Name -> [(Decl, Maybe Doc)]
+classDecls :: TyClDecl Name -> [(Decl, MaybeDocStrings)]
classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass
@@ -190,7 +208,7 @@ declName _ = error "unexpected argument to declName"
-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(Decl, Maybe Doc)]
+topDecls :: HsGroup Name -> [(Decl, MaybeDocStrings)]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup
@@ -255,7 +273,7 @@ warnAboutFilteredDecls mdl decls = do
-- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]
+filterDecls :: [(Decl, doc)] -> [(Decl, doc)]
filterDecls decls = filter (isHandled . unL . fst) decls
where
isHandled (ForD (ForeignImport {})) = True
@@ -268,7 +286,7 @@ filterDecls decls = filter (isHandled . unL . fst) decls
-- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]
+filterClasses :: [(Decl, doc)] -> [(Decl, doc)]
filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
| x@(L loc d, doc) <- decls ]
where
@@ -285,12 +303,25 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
-- declaration.
--------------------------------------------------------------------------------
+type MaybeDocStrings = [HsDocString]
+-- avoid [] because we're appending from the left (quadratic),
+-- and avoid adding another package dependency for haddock,
+-- so use the difference-list pattern
+type MaybeDocStringsFast = MaybeDocStrings -> MaybeDocStrings
+docStringEmpty :: MaybeDocStringsFast
+docStringEmpty = id
+docStringSingleton :: HsDocString -> MaybeDocStringsFast
+docStringSingleton = (:)
+docStringAppend :: MaybeDocStringsFast -> MaybeDocStringsFast -> MaybeDocStringsFast
+docStringAppend = (.)
+docStringToList :: MaybeDocStringsFast -> MaybeDocStrings
+docStringToList = ($ [])
-- | Collect the docs and attach them to the right declaration.
-collectDocs :: [Decl] -> [(Decl, (Maybe Doc))]
-collectDocs = collect Nothing DocEmpty
+collectDocs :: [Decl] -> [(Decl, MaybeDocStrings)]
+collectDocs = collect Nothing docStringEmpty
-collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))]
+collect :: Maybe Decl -> MaybeDocStringsFast -> [Decl] -> [(Decl, MaybeDocStrings)]
collect d doc_so_far [] =
case d of
Nothing -> []
@@ -300,19 +331,24 @@ collect d doc_so_far (e:es) =
case e of
L _ (DocD (DocCommentNext str)) ->
case d of
- Nothing -> collect d (docAppend doc_so_far str) es
- Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)
+ Nothing -> collect d
+ (docStringAppend doc_so_far (docStringSingleton str))
+ es
+ Just d0 -> finishedDoc d0 doc_so_far (collect Nothing
+ (docStringSingleton str)
+ es)
- L _ (DocD (DocCommentPrev str)) -> collect d (docAppend doc_so_far str) es
+ L _ (DocD (DocCommentPrev str)) -> collect d
+ (docStringAppend doc_so_far (docStringSingleton str))
+ es
_ -> case d of
Nothing -> collect (Just e) doc_so_far es
- Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)
+ Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) docStringEmpty es)
-finishedDoc :: Decl -> Doc -> [(Decl, (Maybe Doc))] -> [(Decl, (Maybe Doc))]
-finishedDoc d DocEmpty rest = (d, Nothing) : rest
-finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest
+finishedDoc :: Decl -> MaybeDocStringsFast -> [(Decl, MaybeDocStrings)] -> [(Decl, MaybeDocStrings)]
+finishedDoc d doc rest | notDocDecl d = (d, docStringToList doc) : rest
where
notDocDecl (L _ (DocD _)) = False
notDocDecl _ = True
@@ -336,6 +372,7 @@ attachATs exports =
mkExportItems
:: ModuleMap
-> Module -- this module
+ -> GlobalRdrEnv
-> [Name] -- exported names (orig)
-> [DeclInfo]
-> Map Name DeclInfo -- maps local names to declarations
@@ -346,7 +383,7 @@ mkExportItems
-> InstIfaceMap
-> ErrMsgGhc [ExportItem Name]
-mkExportItems modMap this_mod exported_names decls declMap
+mkExportItems modMap this_mod gre exported_names decls declMap
opts maybe_exps ignore_all_exports _ instIfaceMap
| isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
= everything_local_exported
@@ -357,7 +394,7 @@ mkExportItems modMap this_mod exported_names decls declMap
-- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ]
everything_local_exported = -- everything exported
- return (fullContentsOfThisModule decls)
+ liftErrMsg $ fullContentsOfThisModule gre decls
lookupExport (IEVar x) = declWith x
@@ -371,13 +408,22 @@ mkExportItems modMap this_mod exported_names decls declMap
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) = fullContentsOf m
- lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ]
- lookupExport (IEDoc doc) = return [ ExportDoc doc ]
- lookupExport (IEDocNamed str) = do
- r <- liftErrMsg $ findNamedDoc str [ unL d | (d,_,_) <- decls ]
- case r of
- Nothing -> return []
- Just found -> return [ ExportDoc found ]
+ lookupExport (IEGroup lev docStr) = liftErrMsg $ do
+ ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr)
+ (\doc -> return [ ExportGroup lev "" doc ])
+ lookupExport (IEDoc docStr) = liftErrMsg $ do
+ ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+ (\doc -> return [ ExportDoc doc ])
+ lookupExport (IEDocNamed str) = liftErrMsg $ do
+ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ])
+ (\docStr ->
+ ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+ (\doc -> return [ ExportDoc doc ]))
+
+ ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b]
+ ifDoc parse finish = do
+ mbDoc <- parse
+ case mbDoc of Nothing -> return []; Just doc -> finish doc
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
@@ -460,7 +506,7 @@ mkExportItems modMap this_mod exported_names decls declMap
isExported n = n `elem` exported_names
fullContentsOf modname
- | m == this_mod = return (fullContentsOfThisModule decls)
+ | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
| otherwise =
case Map.lookup m modMap of
Just iface
@@ -509,14 +555,16 @@ mkExportItems modMap this_mod exported_names decls declMap
-- (For more information, see Trac #69)
-fullContentsOfThisModule :: [DeclInfo] -> [ExportItem Name]
-fullContentsOfThisModule decls = catMaybes (map mkExportItem decls)
+fullContentsOfThisModule :: GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name]
+fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls
where
- mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc
- mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _) = Just $ ExportDoc doc
- mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subs []
-
--- mkExportItem _ = Nothing -- TODO: see if this is really needed
+ mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do
+ mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr
+ return $ fmap (\doc -> ExportGroup lev "" doc) mbDoc
+ mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do
+ mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr
+ return $ fmap ExportDoc mbDoc
+ mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs []
-- | Sometimes the declaration we want to export is not the "main" declaration:
@@ -598,7 +646,7 @@ mkVisibleNames exports opts
-- | Find a stand-alone documentation comment by its name
-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe Doc)
+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
findNamedDoc name decls = search decls
where
search [] = do
diff --git a/src/Haddock/Interface/Lex.x b/src/Haddock/Interface/Lex.x
new file mode 100644
index 00000000..5f93084a
--- /dev/null
+++ b/src/Haddock/Interface/Lex.x
@@ -0,0 +1,171 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+-- This file was modified and integrated into GHC by David Waern 2006
+--
+
+{
+{-# OPTIONS -Wwarn -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 Haddock.Interface.Lex (
+ Token(..),
+ tokenise
+ ) where
+
+import Lexer hiding (Token)
+import Parser ( parseIdentifier )
+import StringBuffer
+import RdrName
+import SrcLoc
+import DynFlags
+
+import Data.Char
+import Numeric
+import System.IO.Unsafe
+}
+
+$ws = $white # \n
+$digit = [0-9]
+$hexdigit = [0-9a-fA-F]
+$special = [\"\@]
+$alphanum = [A-Za-z0-9]
+$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
+
+:-
+
+-- beginning of a paragraph
+<0,para> {
+ $ws* \n ;
+ $ws* \> { begin birdtrack }
+ $ws* [\*\-] { token TokBullet `andBegin` string }
+ $ws* \[ { token TokDefStart `andBegin` def }
+ $ws* \( $digit+ \) { token TokNumber `andBegin` string }
+ $ws* { begin string }
+}
+
+-- beginning of a line
+<line> {
+ $ws* \> { begin birdtrack }
+ $ws* \n { token TokPara `andBegin` para }
+ -- Here, we really want to be able to say
+ -- $ws* (\n | <eof>) { token TokPara `andBegin` para}
+ -- because otherwise a trailing line of whitespace will result in
+ -- a spurious TokString at the end of a docstring. We don't have <eof>,
+ -- though (NOW I realise what it was for :-). To get around this, we always
+ -- append \n to the end of a docstring.
+ () { begin string }
+}
+
+<birdtrack> .* \n? { strtokenNL TokBirdTrack `andBegin` line }
+
+<string,def> {
+ $special { strtoken $ \s -> TokSpecial (head s) }
+ \<\<.*\>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) }
+ \<.*\> { strtoken $ \s -> TokURL (init (tail s)) }
+ \#.*\# { strtoken $ \s -> TokAName (init (tail s)) }
+ \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) }
+ [\'\`] $ident+ [\'\`] { ident }
+ \\ . { strtoken (TokString . tail) }
+ "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
+ "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
+ -- allow special characters through if they don't fit one of the previous
+ -- patterns.
+ [\/\'\`\<\#\&\\] { strtoken TokString }
+ [^ $special \/ \< \# \n \'\` \& \\ \]]* \n { strtokenNL TokString `andBegin` line }
+ [^ $special \/ \< \# \n \'\` \& \\ \]]+ { strtoken TokString }
+}
+
+<def> {
+ \] { token TokDefEnd `andBegin` string }
+}
+
+-- ']' doesn't have any special meaning outside of the [...] at the beginning
+-- of a definition paragraph.
+<string> {
+ \] { strtoken TokString }
+}
+
+{
+data Token
+ = TokPara
+ | TokNumber
+ | TokBullet
+ | TokDefStart
+ | TokDefEnd
+ | TokSpecial Char
+ | TokIdent [RdrName]
+ | TokString String
+ | TokURL String
+ | TokPic String
+ | TokEmphasis String
+ | TokAName String
+ | TokBirdTrack String
+-- deriving Show
+
+-- -----------------------------------------------------------------------------
+-- Alex support stuff
+
+type StartCode = Int
+type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
+
+type AlexInput = (Char,String)
+
+alexGetChar (_, []) = Nothing
+alexGetChar (_, c:cs) = Just (c, (c,cs))
+
+alexInputPrevChar (c,_) = c
+
+tokenise :: String -> [Token]
+tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
+ where go inp@(_,str) sc =
+ case alexScan inp sc of
+ AlexEOF -> []
+ AlexError _ -> error "lexical error"
+ AlexSkip inp' _ -> go inp' sc
+ AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
+
+-- NB. we add a final \n to the string, (see comment in the beginning of line
+-- production above).
+eofHack str = str++"\n"
+
+andBegin :: Action -> StartCode -> Action
+andBegin act new_sc = \str _ cont -> act str new_sc cont
+
+token :: Token -> Action
+token t = \_ sc cont -> t : cont sc
+
+strtoken, strtokenNL :: (String -> Token) -> Action
+strtoken t = \str sc cont -> t str : cont sc
+strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc
+-- ^ We only want LF line endings in our internal doc string format, so we
+-- filter out all CRs.
+
+begin :: StartCode -> Action
+begin sc = \_ _ cont -> cont sc
+
+-- -----------------------------------------------------------------------------
+-- Lex a string as a Haskell identifier
+
+ident :: Action
+ident str sc cont =
+ case strToHsQNames id of
+ Just names -> TokIdent names : cont sc
+ Nothing -> TokString str : cont sc
+ where id = init (tail str)
+
+strToHsQNames :: String -> Maybe [RdrName]
+strToHsQNames str0 =
+ let buffer = unsafePerformIO (stringToStringBuffer str0)
+ pstate = mkPState buffer noSrcLoc defaultDynFlags
+ result = unP parseIdentifier pstate
+ in case result of
+ POk _ name -> Just [unLoc name]
+ _ -> Nothing
+}
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
new file mode 100644
index 00000000..04464e77
--- /dev/null
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -0,0 +1,89 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.LexParseRn
+-- Copyright : (c) Isaac Dupree 2009,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.LexParseRn (
+ HaddockCommentType(..),
+ lexParseRnHaddockComment,
+ lexParseRnHaddockCommentList,
+ lexParseRnMbHaddockComment,
+ lexParseRnHaddockModHeader
+ ) where
+
+import Haddock.Types
+
+import Data.Maybe
+
+#if __GLASGOW_HASKELL__ >= 611
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
+import Haddock.Interface.Rn
+import Haddock.Interface.ParseModuleHeader
+import Haddock.HsDoc
+import FastString
+#endif
+
+import GHC
+import RdrName
+
+data HaddockCommentType = NormalHaddockComment | DocSectionComment
+
+lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (HsDoc Name))
+lexParseRnHaddockCommentList hty gre docStrs = do
+ docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs
+ let docs = catMaybes docMbs
+ let doc = foldl docAppend DocEmpty docs
+ case doc of
+ DocEmpty -> return Nothing
+ _ -> return (Just doc)
+
+lexParseRnHaddockComment :: HaddockCommentType ->
+ GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (HsDoc Name))
+#if __GLASGOW_HASKELL__ >= 611
+lexParseRnHaddockComment hty gre (HsDocString fs) = do
+ let str = unpackFS fs
+ let toks = tokenise str
+ let parse = case hty of
+ NormalHaddockComment -> parseHaddockParagraphs
+ DocSectionComment -> parseHaddockString
+ case parse toks of
+ Nothing -> do
+ tell ["doc comment parse failed: "++str]
+ return Nothing
+ Just doc -> do
+ return (Just (rnHsDoc gre doc))
+#else
+lexParseRnHaddockComment _ _ doc = return (Just doc)
+#endif
+
+lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (HsDoc Name))
+lexParseRnMbHaddockComment _ _ Nothing = return Nothing
+lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d
+
+-- yes, you always get a HaddockModInfo though it might be empty
+lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (HsDoc Name))
+#if __GLASGOW_HASKELL__ >= 611
+lexParseRnHaddockModHeader gre mbStr = do
+ let failure = (emptyHaddockModInfo, Nothing)
+ case mbStr of
+ Nothing -> return failure
+ Just (L _ (HsDocString fs)) -> do
+ let str = unpackFS fs
+ case parseModuleHeader str of
+ Left mess -> do
+ tell ["haddock module header parse failed: " ++ mess]
+ return failure
+ Right (info, doc) ->
+ return (rnHaddockModInfo gre info, Just (rnHsDoc gre doc))
+#else
+lexParseRnHaddockModHeader _ hdr = return hdr
+#endif
+
diff --git a/src/Haddock/Interface/Parse.y b/src/Haddock/Interface/Parse.y
new file mode 100644
index 00000000..f420c8e4
--- /dev/null
+++ b/src/Haddock/Interface/Parse.y
@@ -0,0 +1,106 @@
+{
+{-# OPTIONS -Wwarn -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 Haddock.Interface.Parse (
+ parseHaddockParagraphs,
+ parseHaddockString
+) where
+
+import Haddock.Interface.Lex
+import Haddock.Types (HsDoc(..))
+import Haddock.HsDoc
+import HsSyn
+import RdrName
+}
+
+%expect 0
+
+%tokentype { Token }
+
+%token '/' { TokSpecial '/' }
+ '@' { TokSpecial '@' }
+ '[' { TokDefStart }
+ ']' { TokDefEnd }
+ DQUO { TokSpecial '\"' }
+ URL { TokURL $$ }
+ PIC { TokPic $$ }
+ ANAME { TokAName $$ }
+ '/../' { TokEmphasis $$ }
+ '-' { TokBullet }
+ '(n)' { TokNumber }
+ '>..' { TokBirdTrack $$ }
+ IDENT { TokIdent $$ }
+ PARA { TokPara }
+ STRING { TokString $$ }
+
+%monad { Maybe }
+
+%name parseHaddockParagraphs doc
+%name parseHaddockString seq
+
+%%
+
+doc :: { HsDoc RdrName }
+ : apara PARA doc { docAppend $1 $3 }
+ | PARA doc { $2 }
+ | apara { $1 }
+ | {- empty -} { DocEmpty }
+
+apara :: { HsDoc RdrName }
+ : ulpara { DocUnorderedList [$1] }
+ | olpara { DocOrderedList [$1] }
+ | defpara { DocDefList [$1] }
+ | para { $1 }
+
+ulpara :: { HsDoc RdrName }
+ : '-' para { $2 }
+
+olpara :: { HsDoc RdrName }
+ : '(n)' para { $2 }
+
+defpara :: { (HsDoc RdrName, HsDoc RdrName) }
+ : '[' seq ']' seq { ($2, $4) }
+
+para :: { HsDoc RdrName }
+ : seq { docParagraph $1 }
+ | codepara { DocCodeBlock $1 }
+
+codepara :: { HsDoc RdrName }
+ : '>..' codepara { docAppend (DocString $1) $2 }
+ | '>..' { DocString $1 }
+
+seq :: { HsDoc RdrName }
+ : elem seq { docAppend $1 $2 }
+ | elem { $1 }
+
+elem :: { HsDoc RdrName }
+ : elem1 { $1 }
+ | '@' seq1 '@' { DocMonospaced $2 }
+
+seq1 :: { HsDoc RdrName }
+ : PARA seq1 { docAppend (DocString "\n") $2 }
+ | elem1 seq1 { docAppend $1 $2 }
+ | elem1 { $1 }
+
+elem1 :: { HsDoc RdrName }
+ : STRING { DocString $1 }
+ | '/../' { DocEmphasis (DocString $1) }
+ | URL { DocURL $1 }
+ | PIC { DocPic $1 }
+ | ANAME { DocAName $1 }
+ | IDENT { DocIdentifier $1 }
+ | DQUO strings DQUO { DocModule $2 }
+
+strings :: { String }
+ : STRING { $1 }
+ | STRING strings { $1 ++ $2 }
+
+{
+happyError :: [Token] -> Maybe a
+happyError toks = Nothing
+}
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
new file mode 100644
index 00000000..65bb8dd8
--- /dev/null
+++ b/src/Haddock/Interface/ParseModuleHeader.hs
@@ -0,0 +1,158 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.ParseModuleHeader
+-- Copyright : (c) David Waern, Isaac Dupree 2009,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+
+module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
+
+import Haddock.Types
+import Haddock.Interface.Lex
+import Haddock.Interface.Parse
+
+import RdrName
+
+import Data.Char
+
+-- -----------------------------------------------------------------------------
+-- 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 (HaddockModInfo RdrName, HsDoc 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
+ Nothing -> Left ("Cannot parse Description: " ++ description)
+ Just doc -> Right (Just doc)
+ in
+ case description1 of
+ Left mess -> Left mess
+ Right docOpt -> case parseHaddockParagraphs . tokenise $ str8 of
+ Nothing -> Left "Cannot parse header documentation paragraphs"
+ Just doc -> Right (HaddockModInfo {
+ hmi_description = docOpt,
+ hmi_portability = portabilityOpt,
+ hmi_stability = stabilityOpt,
+ hmi_maintainer = maintainerOpt
+ }, doc)
+
+-- | 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 _ _ [] = ([],[])
+ 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 _ [] = Nothing
+ extractPrefix (c1:cs1) (c2:cs2)
+ | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+ | True = Nothing
+
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 8145d63a..b377b4fb 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -144,6 +144,13 @@ renameExportItems = mapM renameExportItem
renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))
renameMaybeDoc = mapM renameDoc
+#if __GLASGOW_HASKELL__ >= 611
+renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
+renameLDocHsSyn = return
+#else
+renameLDocHsSyn :: LHsDoc Name -> RnM (LHsDoc DocName)
+renameLDocHsSyn = renameLDoc
+#endif
renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName)
renameLDoc = mapM renameDoc
@@ -259,7 +266,7 @@ renameType t = case t of
HsDocTy ty doc -> do
ty' <- renameLType ty
- doc' <- renameLDoc doc
+ doc' <- renameLDocHsSyn doc
return (HsDocTy ty' doc')
_ -> error "renameType"
@@ -363,7 +370,7 @@ renameTyClD d = case d of
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
- mbldoc' <- mapM renameLDoc mbldoc
+ mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
, con_details = details', con_res = restype', con_doc = mbldoc' })
@@ -377,7 +384,7 @@ renameTyClD d = case d of
renameField (ConDeclField name t doc) = do
name' <- renameL name
t' <- renameLType t
- doc' <- mapM renameLDoc doc
+ doc' <- mapM renameLDocHsSyn doc
return (ConDeclField name' t' doc')
renameResType (ResTyH98) = return ResTyH98
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
new file mode 100644
index 00000000..c45b5042
--- /dev/null
+++ b/src/Haddock/Interface/Rn.hs
@@ -0,0 +1,82 @@
+
+module Haddock.Interface.Rn ( rnHsDoc, rnHaddockModInfo ) where
+
+import Haddock.Types
+
+import RnEnv ( dataTcOccs )
+
+import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
+import Name ( Name )
+import Outputable ( ppr, defaultUserStyle )
+
+rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name
+rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =
+ HaddockModInfo (fmap (rnHsDoc gre) desc) port stab maint
+
+ids2string :: [RdrName] -> String
+ids2string [] = []
+ids2string (x:_) = show $ ppr x defaultUserStyle
+
+data Id x = Id {unId::x}
+instance Monad Id where (Id v)>>=f = f v; return = Id
+
+rnHsDoc :: GlobalRdrEnv -> HsDoc RdrName -> HsDoc Name
+rnHsDoc gre = unId . do_rn
+ where
+ do_rn doc_to_rn = case doc_to_rn of
+
+ DocEmpty -> return DocEmpty
+
+ DocAppend a b -> do
+ a' <- do_rn a
+ b' <- do_rn b
+ return (DocAppend a' b')
+
+ DocString str -> return (DocString str)
+
+ DocParagraph doc -> do
+ doc' <- do_rn doc
+ return (DocParagraph doc')
+
+ DocIdentifier ids -> do
+ let choices = concatMap dataTcOccs ids
+ let gres = concatMap (\rdrName ->
+ map gre_name (lookupGRE_RdrName rdrName gre)) choices
+ case gres of
+ [] -> return (DocString (ids2string ids))
+ ids' -> return (DocIdentifier ids')
+
+ DocModule str -> return (DocModule str)
+
+ DocEmphasis doc -> do
+ doc' <- do_rn doc
+ return (DocEmphasis doc')
+
+ DocMonospaced doc -> do
+ doc' <- do_rn doc
+ return (DocMonospaced doc')
+
+ DocUnorderedList docs -> do
+ docs' <- mapM do_rn docs
+ return (DocUnorderedList docs')
+
+ DocOrderedList docs -> do
+ docs' <- mapM do_rn docs
+ return (DocOrderedList docs')
+
+ DocDefList list -> do
+ list' <- mapM (\(a,b) -> do
+ a' <- do_rn a
+ b' <- do_rn b
+ return (a', b')) list
+ return (DocDefList list')
+
+ DocCodeBlock doc -> do
+ doc' <- do_rn doc
+ return (DocCodeBlock doc')
+
+ DocURL str -> return (DocURL str)
+
+ DocPic str -> return (DocPic str)
+
+ DocAName str -> return (DocAName str)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 06:17:09 +0000