From 70945271f1f4deab363c1acfef3ce51a1b7f617d Mon Sep 17 00:00:00 2001 From: Isaac Dupree Date: Sun, 23 Aug 2009 03:08:03 +0000 Subject: Move doc parsing/lexing into Haddock for ghc>=6.11 --- src/Haddock/Interface/Create.hs | 140 +++++++++++++++-------- src/Haddock/Interface/Lex.x | 171 +++++++++++++++++++++++++++++ src/Haddock/Interface/LexParseRn.hs | 89 +++++++++++++++ src/Haddock/Interface/Parse.y | 106 ++++++++++++++++++ src/Haddock/Interface/ParseModuleHeader.hs | 158 ++++++++++++++++++++++++++ src/Haddock/Interface/Rename.hs | 13 ++- src/Haddock/Interface/Rn.hs | 82 ++++++++++++++ 7 files changed, 710 insertions(+), 49 deletions(-) create mode 100644 src/Haddock/Interface/Lex.x create mode 100644 src/Haddock/Interface/LexParseRn.hs create mode 100644 src/Haddock/Interface/Parse.y create mode 100644 src/Haddock/Interface/ParseModuleHeader.hs create mode 100644 src/Haddock/Interface/Rn.hs (limited to 'src/Haddock/Interface') 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 + { + $ws* \> { begin birdtrack } + $ws* \n { token TokPara `andBegin` para } + -- Here, we really want to be able to say + -- $ws* (\n | ) { 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 , + -- though (NOW I realise what it was for :-). To get around this, we always + -- append \n to the end of a docstring. + () { begin string } +} + + .* \n? { strtokenNL TokBirdTrack `andBegin` line } + + { + $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 } +} + + { + \] { token TokDefEnd `andBegin` string } +} + +-- ']' doesn't have any special meaning outside of the [...] at the beginning +-- of a definition paragraph. + { + \] { 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) -- cgit v1.2.3