From d327e3dfea1dda473c065b0e6a7da2161c9e6668 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 12 Jan 2012 11:54:37 +0100 Subject: Add DocWarning to Doc The Xhtml backend has special markup for that, Hoogle and LaTeX reuse what we have for DocEmphasis. --- src/Haddock/Interface/Rename.hs | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src/Haddock/Interface/Rename.hs') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 691dafbc..582c2ccd 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -169,6 +169,9 @@ renameDoc d = case d of return (DocIdentifier x') DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x) DocModule str -> return (DocModule str) + DocWarning doc -> do + doc' <- renameDoc doc + return (DocWarning doc') DocEmphasis doc -> do doc' <- renameDoc doc return (DocEmphasis doc') -- cgit v1.2.3 From 12d931b4c3fcd6d8e26cc48b9072b4291efa5cdb Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 4 Feb 2012 21:37:16 +0100 Subject: Mostly hlint-inspired cleanup. --- src/Haddock/Backends/Hoogle.hs | 4 +- src/Haddock/Backends/Xhtml.hs | 6 +-- src/Haddock/Backends/Xhtml/Decl.hs | 65 ++++++++++++++---------------- src/Haddock/Backends/Xhtml/Utils.hs | 4 +- src/Haddock/Interface/Create.hs | 24 +++++------ src/Haddock/Interface/ParseModuleHeader.hs | 6 +-- src/Haddock/Interface/Rename.hs | 20 +++++---- src/Haddock/InterfaceFile.hs | 34 ++++++++-------- src/Haddock/Types.hs | 2 +- src/Haddock/Utils.hs | 9 ++--- 10 files changed, 86 insertions(+), 88 deletions(-) (limited to 'src/Haddock/Interface/Rename.hs') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index cbb5921d..e7a78fc2 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -101,7 +101,7 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr operator :: String -> String -operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")" +operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x @@ -124,7 +124,7 @@ ppExport _ = [] ppSig :: Sig Name -> [String] ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] where - prettyNames = concat . intersperse ", " $ map out names + prettyNames = intercalate ", " $ map out names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index c8998f3e..84468610 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -431,7 +431,7 @@ ppHtmlIndex odir doctitle _maybe_package themes indexLinks nm entries many_entities -> td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml - aboves (map doAnnotatedEntity (zip [1..] many_entities)) + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable doAnnotatedEntity (j,(nm,entries)) @@ -539,7 +539,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual maybe_doc_hdr = case exports of [] -> noHtml - ExportGroup _ _ _ : _ -> noHtml + ExportGroup {} : _ -> noHtml _ -> h1 << "Documentation" bdy = @@ -621,7 +621,7 @@ ppModuleContents qual exports -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] -numberSectionHeadings exports = go 1 exports +numberSectionHeadings = go 1 where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] go _ [] = [] go n (ExportGroup lev _ doc : es) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 9d7865f2..5cdc819c 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -79,7 +79,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> (HsType DocName) -> [SubDecl] + do_args :: Int -> Html -> HsType DocName -> [SubDecl] do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> @@ -99,7 +99,7 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = (leader <+> ppType unicode qual t, argDoc n, []) : [] + = [(leader <+> ppType unicode qual t, argDoc n, [])] ppTyVars :: [LHsTyVarBndr DocName] -> [Html] @@ -296,12 +296,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual <+> darrow unicode @@ -309,10 +309,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html -pp_hs_context [] _ _ = noHtml -pp_hs_context [p] unicode qual = ppType unicode qual p -pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ------------------------------------------------------------------------------- @@ -326,8 +326,8 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode qual + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html @@ -396,7 +396,7 @@ ppClassDecl summary links instances loc mbDoc subdocs -- there are different subdocs for different names in a single -- type signature? - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" @@ -413,11 +413,8 @@ ppInstances instances baseName unicode qual <+> ppAppNameTypes n ts unicode qual -lookupAnySubdoc :: (Eq name1) => - name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 -lookupAnySubdoc n subdocs = case lookup n subdocs of - Nothing -> noDocForDecl - Just docs -> docs +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n ------------------------------------------------------------------------------- @@ -430,7 +427,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Qualification -> Html ppShortDataDecl summary _links _loc dataDecl unicode qual - | [] <- cons = dataHeader + | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy, (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual @@ -513,7 +510,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of -- (except each field gets its own line in docs, to match -- non-GADT records) RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> - ppForAll forall ltvs lcontext unicode qual <+> char '{', + ppForAll forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) @@ -521,29 +518,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of where doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode qual, + ppForAll forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con mkFunTy a b = noLoc (HsFunTy a b) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Qualification -> Html -ppConstrHdr forall tvs ctxt unicode qual +ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual <+> darrow unicode +++ toHtml " ") where - ppForall = case forall of + ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> noHtml @@ -581,15 +578,15 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode - <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual, + <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. -- 'join' is in Maybe. @@ -651,13 +648,13 @@ tupleParens _ = parenList pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic +pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC +pREC_FUN = 1 :: Int -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = 2 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 3 :: Int -- Used for arg of type applicn: + -- always parenthesise unless atomic maybeParen :: Int -- Precedence of context -> Int -- Precedence of top-level operator @@ -699,7 +696,7 @@ ppForAll expl tvs cxt unicode qual ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html -ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index c020c64d..be1fcb9b 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -44,7 +44,7 @@ import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of @@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url run ('%':'N':rest) = name ++ run rest run ('%':'K':rest) = kind ++ run rest run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = "%" ++ run rest + run ('%':'%':rest) = '%' : run rest run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 737547fd..ed51734d 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -350,7 +350,7 @@ warnAboutFilteredDecls mdl decls = do tell [ "Warning: " ++ modStr ++ ": Instances of type and data " ++ "families are not yet supported. Instances of the following families " - ++ "will be filtered out:\n " ++ concat (intersperse ", " + ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls @@ -359,7 +359,7 @@ warnAboutFilteredDecls mdl decls = do unless (null instances) $ tell [ "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " - ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ] + ++ "These instances are affected:\n" ++ intercalate ", " instances ] -------------------------------------------------------------------------------- @@ -371,7 +371,7 @@ warnAboutFilteredDecls mdl decls = do -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls decls = filter (isHandled . unL . fst) decls +filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True @@ -408,10 +408,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs ((L _ (DocD (DocCommentNext str))):ds) + go prev docs (L _ (DocD (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs ((L _ (DocD (DocCommentPrev str))):ds) = go prev (str:docs) ds + go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -489,7 +489,7 @@ mkExportItems -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. - | not $ t `elem` declNames, + | t `notElem` declNames, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ @@ -517,7 +517,7 @@ mkExportItems mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] - Just decl -> do + Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package. case M.lookup (nameModule t) instIfaceMap of @@ -526,7 +526,7 @@ mkExportItems ["Warning: Couldn't find .haddock for export " ++ pretty t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] - Just iface -> do + Just iface -> return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -736,9 +736,9 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- Pruning +-- | Keep exprt items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] -pruneExportItems items = filter hasDoc items +pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d hasDoc _ = True @@ -758,12 +758,12 @@ mkVisibleNames exports opts -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) -findNamedDoc name decls = search decls +findNamedDoc name = search where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search ((DocD (DocCommentNamed name' doc)):rest) + search (DocD (DocCommentNamed name' doc) : rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index 35533d0d..411b6661 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -137,14 +137,14 @@ parseKey key toParse0 = (spaces1,cs1) = extractLeadingSpaces cs in (c:spaces1,cs1) - | True = ([],s) + | otherwise = ([],s) extractNextLine :: String -> (String,String) extractNextLine [] = ([],[]) extractNextLine (c:cs) | c == '\n' = ([],cs) - | True = + | otherwise = let (line,rest) = extractNextLine cs in @@ -156,5 +156,5 @@ parseKey key toParse0 = extractPrefix _ [] = Nothing extractPrefix (c1:cs1) (c2:cs2) | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | True = Nothing + | otherwise = Nothing diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 582c2ccd..cffe68b8 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -12,19 +12,20 @@ module Haddock.Interface.Rename (renameInterface) where -import Haddock.Types import Haddock.GhcUtils +import Haddock.Types -import GHC hiding (NoLink) -import Name import Bag (emptyBag) import BasicTypes ( IPName(..), ipNameName ) +import GHC hiding (NoLink) +import Name +import Control.Applicative +import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Prelude hiding (mapM) import Data.Traversable (mapM) -import Control.Monad hiding (mapM) +import Prelude hiding (mapM) renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface @@ -93,6 +94,9 @@ instance Monad (GenRnM n) where (>>=) = thenRn return = returnRn +instance Functor (GenRnM n) where + fmap f x = do a <- x; return (f a) + returnRn :: a -> GenRnM n a returnRn a = RnM (const (a,[])) thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b @@ -211,7 +215,7 @@ renameLKind = renameLType renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind Nothing = return Nothing -renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just +renameMaybeLKind (Just ki) = Just <$> renameLKind ki renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of @@ -241,11 +245,11 @@ renameType t = case t of HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, (L loc op)) b -> do + HsOpTy a (w, L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, (L loc op')) b') + return (HsOpTy a' (w, L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index e998ffec..970093df 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -22,24 +22,25 @@ module Haddock.InterfaceFile ( import Haddock.Types import Haddock.Utils hiding (out) -import Data.List -import Data.Word +import Control.Monad import Data.Array import Data.IORef +import Data.List import qualified Data.Map as Map import Data.Map (Map) +import Data.Word -import GHC hiding (NoLink) -import Binary import BinIface (getSymtabName, getDictFastString) -import Name -import UniqSupply -import UniqFM -import IfaceEnv -import HscTypes -import GhcMonad (withSession) +import Binary import FastMutInt import FastString +import GHC hiding (NoLink) +import GhcMonad (withSession) +import HscTypes +import IfaceEnv +import Name +import UniqFM +import UniqSupply import Unique @@ -110,8 +111,8 @@ writeInterfaceFile filename iface = do bin_dict_map = dict_map_ref } -- put the main thing - bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab) - (putFastString bin_dict) + let bh = setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) put_ bh iface -- write the symtab pointer at the front of the file @@ -295,12 +296,9 @@ putSymbolTable bh next_off symtab = do getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) getSymbolTable bh namecache = do sz <- get bh - od_names <- sequence (replicate sz (get bh)) - let - arr = listArray (0,sz-1) names - (namecache', names) = - mapAccumR (fromOnDiskName arr) namecache od_names - -- + od_names <- replicateM sz (get bh) + let arr = listArray (0,sz-1) names + (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names return (namecache', arr) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 927fcffb..22d2f6ae 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -430,7 +430,7 @@ throwE str = throw (HaddockException str) -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) } +newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } --instance MonadIO ErrMsgGhc where -- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO --er, implementing GhcMonad involves annoying ExceptionMonad and diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 9865fdf1..3a2f1d28 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -70,7 +70,7 @@ import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) +import System.Exit import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -156,11 +156,11 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail (ConDeclField n _ _) = unLoc n `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] - keep _ | otherwise = Nothing + keep _ = Nothing restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] @@ -286,7 +286,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess +bye s = putStr s >> exitSuccess die :: String -> IO a @@ -319,7 +319,6 @@ escapeStr = escapeURIString isUnreserved -- to avoid depending on the network lib, since doing so gives a -- circular build dependency between haddock and network -- (at least if you want to build network with haddock docs) --- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs escapeURIChar :: (Char -> Bool) -> Char -> String escapeURIChar p c | p c = [c] -- cgit v1.2.3 From e090bbc5bdc8eb34d5340e467c7157341dfdd945 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 16 May 2012 17:14:21 +0200 Subject: newtype-wrap Doc nodes for things that may have warnings attached --- src/Haddock/Backends/Hoogle.hs | 18 ++++++----- src/Haddock/Backends/LaTeX.hs | 56 +++++++++++++++++---------------- src/Haddock/Backends/Xhtml.hs | 12 +++---- src/Haddock/Backends/Xhtml/Decl.hs | 32 +++++++++---------- src/Haddock/Backends/Xhtml/DocMarkup.hs | 10 +++--- src/Haddock/Interface/Create.hs | 12 ++++--- src/Haddock/Interface/Rename.hs | 14 ++++----- src/Haddock/Types.hs | 20 ++++++------ 8 files changed, 89 insertions(+), 85 deletions(-) (limited to 'src/Haddock/Interface/Rename.hs') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index e7a78fc2..98eeaab8 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -48,7 +48,7 @@ ppHoogle package version synopsis prologue ifaces odir = do hClose h ppModule :: Interface -> [String] -ppModule iface = "" : doc (ifaceDoc iface) ++ +ppModule iface = "" : ppDocumentation (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap ppExport (ifaceExportItems iface) ++ concatMap ppInstance (ifaceInstances iface) @@ -109,7 +109,7 @@ operator x = x -- How to print each export ppExport :: ExportItem Name -> [String] -ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl) +ppExport (ExportDecl decl dc subdocs _) = ppDocumentation (fst dc) ++ f (unL decl) where f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d @@ -167,19 +167,19 @@ ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : f w = if w == nam then operator nam else w -- | for constructors, and named-fields... -lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) +lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> [String] lookupCon subdocs (L _ name) = case lookup name subdocs of - Just (d, _) -> d - _ -> Nothing + Just (d, _) -> ppDocumentation d + _ -> [] ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) +ppCtor dat subdocs con = lookupCon subdocs (con_name con) ++ f (con_details con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat - [doc (lookupCon subdocs (cd_fld_name r)) ++ + [lookupCon subdocs (cd_fld_name r) ++ [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] | r <- recs] @@ -197,6 +197,10 @@ ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) --------------------------------------------------------------------- -- DOCUMENTATION +ppDocumentation :: Outputable o => Documentation o -> [String] +ppDocumentation (Documentation d) = doc d + + doc :: Outputable o => Maybe (Doc o) -> [String] doc = docWith "" diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index efe05b9e..6cce753c 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -158,9 +158,7 @@ ppLaTeXModule _title odir iface = do ] description - = case ifaceRnDoc iface of - Nothing -> empty - Just doc -> docToLaTeX doc + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface body = processExports exports -- @@ -210,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) - (Nothing, argDocs) _ _) + (Documentation Nothing, argDocs) _ _) | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -276,24 +274,24 @@ ppDecl :: LHsDecl DocName -> [(DocName, DocForDecl DocName)] -> LaTeX -ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of - TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode +ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of + TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode - | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d + | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc doc d unicode + | Just _ <- tcdTyPats d -> ppDataInst loc doc d TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode - | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode - SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode - ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode + | Nothing <- tcdTyPats d -> ppTySyn loc (doc, fnArgsDoc) d unicode + | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False -ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" @@ -304,7 +302,7 @@ ppDataInst = error "data instance declarations are currently not supported by --latex" -ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) -> +ppTyInst :: Bool -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX ppTyInst _ _ _ _ _ = error "type instance declarations are currently not supported by --latex" @@ -355,13 +353,13 @@ ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) unicode | Map.null argDocs = - declWithDoc pref1 (fmap docToLaTeX doc) + declWithDoc pref1 (documentationToLaTeX doc) | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ do_args 0 sep0 typ $$ text "\\end{tabulary}\\par" $$ - maybe empty docToLaTeX doc + fromMaybe empty (documentationToLaTeX doc) where do_largs n leader (L _ t) = do_args n leader t @@ -469,9 +467,9 @@ ppFds fds unicode = ppClassDecl :: [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX -ppClassDecl instances loc mbDoc subdocs +ppClassDecl instances loc doc subdocs (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit @@ -482,7 +480,7 @@ ppClassDecl instances loc mbDoc subdocs hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds - body = catMaybes [fmap docToLaTeX mbDoc, body_] + body = catMaybes [documentationToLaTeX doc, body_] body_ | null lsigs, null ats, null at_defs = Nothing @@ -523,8 +521,8 @@ isUndocdInstance _ = Nothing -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, mbDoc) = - declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc) +ppDocInstance unicode (instHead, doc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) ppInstDecl :: Bool -> InstHead DocName -> LaTeX @@ -550,9 +548,9 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ppDataDecl :: [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX -ppDataDecl instances subdocs _loc mbDoc dataDecl unicode +ppDataDecl instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body)) @@ -562,7 +560,7 @@ ppDataDecl instances subdocs _loc mbDoc dataDecl unicode cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - body = catMaybes [constrBit, fmap docToLaTeX mbDoc] + body = catMaybes [constrBit, documentationToLaTeX doc] (whereBit, leaders) | null cons = (empty,[]) @@ -642,7 +640,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -652,7 +650,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= fst + mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -1042,6 +1040,10 @@ docToLaTeX :: Doc DocName -> LaTeX docToLaTeX doc = markup latexMarkup doc Plain +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc + + rdrDocToLaTeX :: Doc RdrName -> LaTeX rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 94ca6d10..c5925cda 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -508,18 +508,16 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc (ExportDecl _ doc _ _) = isJust (fst doc) + has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True no_doc_at_all = not (any has_doc exports) - description - = case ifaceRnDoc iface of - Nothing -> noHtml - Just doc -> divDescription $ - sectionName << "Description" +++ docSection qual doc + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis @@ -639,7 +637,7 @@ processExport summary _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual y +++ parenList (map (ppDocName qual) subs) processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection qual doc + = nothingIf summary $ docSection_ qual doc processExport summary _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 3cfba1de..66b78cbd 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -71,9 +71,9 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual | summary = pref1 - | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc + | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc | otherwise = topDeclElem links loc docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc + subArguments qual (do_args 0 sep typ) +++ docSection qual doc where argDoc n = Map.lookup n argDocs @@ -166,12 +166,12 @@ ppTyFamHeader summary associated decl unicode qual = Nothing -> noHtml -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyFam summary associated links loc mbDoc decl unicode qual +ppTyFam summary associated links loc doc decl unicode qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ instancesBit where docname = tcdName decl @@ -206,12 +206,12 @@ ppDataInst = undefined -------------------------------------------------------------------------------- -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInst summary associated links loc mbDoc decl unicode qual +ppTyInst summary associated links loc doc decl unicode qual | summary = ppTyInstHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc + | otherwise = header_ +++ docSection qual doc where docname = tcdName decl @@ -367,12 +367,12 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html -ppClassDecl summary links instances loc mbDoc subdocs +ppClassDecl summary links instances loc d subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual - | otherwise = classheader +++ maybeDocSection qual mbDoc + | otherwise = classheader +++ docSection qual d +++ atBit +++ methodBit +++ instancesBit where classheader @@ -449,12 +449,12 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual +ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual | summary = ppShortDataDecl summary links loc dataDecl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl @@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= fst + mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index ee0a549f..cd1595f6 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( rdrDocToHtml, origDocToHtml, - docElement, docSection, maybeDocSection, + docElement, docSection, docSection_, ) where @@ -85,12 +85,12 @@ docElement el content_ = else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Doc DocName -> Html -docSection qual = (docElement thediv <<) . docToHtml qual +docSection :: Qualification -> Documentation DocName -> Html +docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc -maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html -maybeDocSection qual = maybe noHtml (docSection qual) +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual cleanup :: Doc a -> Doc a diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index ea4636fe..e2cc9959 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -117,8 +117,8 @@ createInterface tm flags modMap instIfaceMap = do ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, - ifaceDoc = mbDoc, - ifaceRnDoc = Nothing, + ifaceDoc = Documentation mbDoc, + ifaceRnDoc = Documentation Nothing, ifaceOptions = opts, ifaceDocMap = docMap, ifaceArgMap = argMap, @@ -609,10 +609,12 @@ hiValExportItem name doc = do lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) lookupDocs n docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in - let doc = (M.lookup n docMap, lookupArgDoc n) in + let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (M.lookup s docMap, lookupArgDoc s)) | s <- subs ] in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) + where + lookupDoc = Documentation . (`M.lookup` docMap) -- | Return all export items produced by an exported module. That is, we're @@ -772,7 +774,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d + hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index cffe68b8..fd2a1f10 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -47,7 +47,7 @@ renameInterface renamingEnv warnings iface = (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) (finalModuleDoc, missingNames4) - = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) + = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. @@ -142,15 +142,13 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] renameExportItems = mapM renameExportItem -renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName) -renameDocForDecl (mbDoc, fnArgsDoc) = do - mbDoc' <- renameMaybeDoc mbDoc - fnArgsDoc' <- renameFnArgsDoc fnArgsDoc - return (mbDoc', fnArgsDoc') +renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) +renameDocForDecl (doc, fnArgsDoc) = + (,) `fmap` renameDocumentation doc `ap` renameFnArgsDoc fnArgsDoc -renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName)) -renameMaybeDoc = mapM renameDoc +renameDocumentation :: Documentation Name -> RnM (Documentation DocName) +renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc renameLDocHsSyn :: LHsDocString -> RnM LHsDocString diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 97d56a52..f8d51b2b 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -67,10 +67,10 @@ data Interface = Interface , ifaceInfo :: !(HaddockModInfo Name) -- | Documentation header. - , ifaceDoc :: !(Maybe (Doc Name)) + , ifaceDoc :: !(Documentation Name) -- | Documentation header with cross-reference information. - , ifaceRnDoc :: Maybe (Doc DocName) + , ifaceRnDoc :: Documentation DocName -- | Haddock options for this module (prune, ignore-exports, etc). , ifaceOptions :: ![DocOption] @@ -214,19 +214,23 @@ data ExportItem name | ExportModule Module +newtype Documentation name = Documentation (Maybe (Doc name)) + deriving Functor + + -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (Doc name) -type DocForDecl name = (Maybe (Doc name), FnArgsDoc name) +type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Nothing, Map.empty) +noDocForDecl = (Documentation Nothing, Map.empty) unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -unrenameDocForDecl (mbDoc, fnArgsDoc) = - (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc) +unrenameDocForDecl (doc, fnArgsDoc) = + (fmap getName doc, (fmap . fmap) getName fnArgsDoc) ----------------------------------------------------------------------------- @@ -304,10 +308,6 @@ instance Monoid (Doc id) where mappend = DocAppend -unrenameDoc :: Doc DocName -> Doc Name -unrenameDoc = fmap getName - - data Example = Example { exampleExpression :: String , exampleResult :: [String] -- cgit v1.2.3 From a6bcb1e464ff33161f84c5794f5ae239604fb7e5 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 17 May 2012 18:35:21 +0200 Subject: Attach warnings to `Documentation` type --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/LaTeX.hs | 8 ++-- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 4 +- src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- src/Haddock/Interface/Create.hs | 75 +++++++++++++++------------------ src/Haddock/Interface/Rename.hs | 3 +- src/Haddock/Types.hs | 13 ++++-- 8 files changed, 56 insertions(+), 53 deletions(-) (limited to 'src/Haddock/Interface/Rename.hs') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 98eeaab8..d27ca80f 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -198,7 +198,7 @@ ppCtor dat subdocs con = lookupCon subdocs (con_name con) -- DOCUMENTATION ppDocumentation :: Outputable o => Documentation o -> [String] -ppDocumentation (Documentation d) = doc d +ppDocumentation (Documentation d w) = doc d ++ doc w doc :: Outputable o => Maybe (Doc o) -> [String] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index 6cce753c..31ba3b0b 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -208,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) - (Documentation Nothing, argDocs) _ _) + (Documentation Nothing Nothing, argDocs) _ _) | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -640,7 +640,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -650,7 +650,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup name subdocs >>= combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -1041,7 +1041,7 @@ docToLaTeX doc = markup latexMarkup doc Plain documentationToLaTeX :: Documentation DocName -> Maybe LaTeX -documentationToLaTeX (Documentation mDoc) = docToLaTeX `fmap` mDoc +documentationToLaTeX = fmap docToLaTeX . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index c5925cda..5a3cbac0 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -508,7 +508,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc (ExportDecl _ (Documentation mDoc, _) _ _) = isJust mDoc + has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 66b78cbd..21a33ea8 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -588,7 +588,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -600,7 +600,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= (\(Documentation mDoc) -> mDoc) . fst + mbDoc = lookup name subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index cd1595f6..052116ee 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -86,7 +86,7 @@ docElement el content_ = docSection :: Qualification -> Documentation DocName -> Html -docSection qual (Documentation doc) = maybe noHtml (docSection_ qual) doc +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation docSection_ :: Qualification -> Doc DocName -> Html diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index e2cc9959..1513349f 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -72,28 +72,23 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- do - (i, d) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader - return (i, addModuleWarning warnings d) + (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - (docMap0, argMap, subMap, declMap) <- + maps@(docMap, argMap, subMap, declMap) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs - let docMap = addWarnings warnings gre exportedNames docMap0 - maps = (docMap, argMap, subMap, declMap) - - exports0 = fmap (reverse . map unLoc) mayExports + let exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 liftErrMsg $ warnAboutFilteredDecls mdl decls - exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports + exportItems <- mkExportItems modMap mdl warnings gre exportedNames decls maps exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -117,8 +112,8 @@ createInterface tm flags modMap instIfaceMap = do ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, - ifaceDoc = Documentation mbDoc, - ifaceRnDoc = Documentation Nothing, + ifaceDoc = Documentation mbDoc (moduleWarning warnings), + ifaceRnDoc = Documentation Nothing Nothing, ifaceOptions = opts, ifaceDocMap = docMap, ifaceArgMap = argMap, @@ -169,25 +164,23 @@ lookupModuleDyn dflags Nothing mdlName = ------------------------------------------------------------------------------- --- | Add warnings to documentation. If there is a warning for an identifier --- with no documentation, create a piece of documentation that just contains --- the warning. -addWarnings :: Warnings -> GlobalRdrEnv -> [Name] -> DocMap Name -> DocMap Name -addWarnings NoWarnings _ _ dm = dm -addWarnings (WarnAll _) _ _ dm = dm -addWarnings (WarnSome ws) gre exps dm = M.unionWith (flip (<>)) dm wm +-- FIXME: simplify +lookupWarning :: Warnings -> GlobalRdrEnv -> Name -> Maybe (Doc id) +lookupWarning NoWarnings _ _ = Nothing +lookupWarning (WarnAll _) _ _ = Nothing +lookupWarning (WarnSome ws) gre name = M.lookup name wm where wm = M.fromList [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = gre_name elt, n == name ] -addModuleWarning :: Warnings -> Maybe (Doc id) -> Maybe (Doc id) -addModuleWarning ws = +moduleWarning :: Warnings -> Maybe (Doc id) +moduleWarning ws = case ws of - NoWarnings -> id - WarnSome _ -> id - WarnAll w -> let d = warnToDoc w in Just . maybe d (d <>) + NoWarnings -> Nothing + WarnSome _ -> Nothing + WarnAll w -> Just (warnToDoc w) warnToDoc :: WarningTxt -> Doc id @@ -459,6 +452,7 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module + -> Warnings -> GlobalRdrEnv -> [Name] -- exported names (orig) -> [LHsDecl Name] @@ -469,10 +463,10 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod gre exportedNames decls0 + modMap thisMod warnings gre exportedNames decls0 (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of - Nothing -> fullModuleContents dflags gre maps decls + Nothing -> fullModuleContents dflags warnings gre maps decls Just exports -> liftM concat $ mapM lookupExport exports where decls = filter (not . isInstD . unLoc) decls0 @@ -483,7 +477,7 @@ mkExportItems lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps + moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (processDocString dflags gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) @@ -559,7 +553,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t warnings gre (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -579,9 +573,9 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n docMap argMap subMap) + (ds, lookupDocs n warnings gre docMap argMap subMap) | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + (ds, lookupDocs n warnings gre (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n @@ -606,15 +600,15 @@ hiValExportItem name doc = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n docMap argMap subMap = +lookupDocs :: Name -> Warnings -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings gre docMap argMap subMap = let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in let subs = M.findWithDefault [] n subMap in let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in (doc, subDocs) where - lookupDoc = Documentation . (`M.lookup` docMap) + lookupDoc name = Documentation (M.lookup name docMap) (lookupWarning warnings gre name) -- | Return all export items produced by an exported module. That is, we're @@ -633,6 +627,7 @@ lookupDocs n docMap argMap subMap = moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A + -> Warnings -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A -> [LHsDecl Name] -- ^ All the declarations in A @@ -640,8 +635,8 @@ moduleExports :: Module -- ^ Module A -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps - | m == thisMod = fullModuleContents dflags gre maps decls +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps + | m == thisMod = fullModuleContents dflags warnings gre maps decls | otherwise = case M.lookup m ifaceMap of Just iface @@ -679,8 +674,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = +fullModuleContents :: DynFlags -> Warnings -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- A type signature can have multiple names, like: @@ -705,12 +700,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = lookupDocs name docMap argMap subMap in + let (doc, _) = lookupDocs name warnings gre docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = lookupDocs name docMap argMap subMap in + let (doc, subs) = lookupDocs name warnings gre docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing @@ -774,7 +769,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d, _)}) = isJust d + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index fd2a1f10..7f322eca 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -148,7 +148,8 @@ renameDocForDecl (doc, fnArgsDoc) = renameDocumentation :: Documentation Name -> RnM (Documentation DocName) -renameDocumentation (Documentation mDoc) = Documentation <$> mapM renameDoc mDoc +renameDocumentation (Documentation mDoc mWarning) = + Documentation `fmap` mapM renameDoc mDoc `ap` mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index f8d51b2b..048a7ff7 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -24,6 +24,7 @@ import Control.Exception import Control.Arrow import Data.Typeable import Data.Map (Map) +import Data.Maybe import qualified Data.Map as Map import Data.Monoid import GHC hiding (NoLink) @@ -213,9 +214,15 @@ data ExportItem name -- | A cross-reference to another module. | ExportModule Module +data Documentation name = Documentation + { documentationDoc :: Maybe (Doc name) + , documentationWarning :: Maybe (Doc name) + } deriving Functor -newtype Documentation name = Documentation (Maybe (Doc name)) - deriving Functor + +combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation (Documentation Nothing Nothing) = Nothing +combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc) -- | Arguments and result are indexed by Int, zero-based from the left, @@ -225,7 +232,7 @@ type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, Map.empty) unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -- cgit v1.2.3 From 095fb18d1965353ad574b93a5d744677a1c9420a Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Sat, 26 May 2012 19:00:42 +0200 Subject: Add Applicative instance for (GenRnM a) --- src/Haddock/Interface/Rename.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src/Haddock/Interface/Rename.hs') diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 7f322eca..b703da0f 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -97,6 +97,10 @@ instance Monad (GenRnM n) where instance Functor (GenRnM n) where fmap f x = do a <- x; return (f a) +instance Applicative (GenRnM n) where + pure = return + (<*>) = ap + returnRn :: a -> GenRnM n a returnRn a = RnM (const (a,[])) thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b @@ -144,12 +148,12 @@ renameExportItems = mapM renameExportItem renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) renameDocForDecl (doc, fnArgsDoc) = - (,) `fmap` renameDocumentation doc `ap` renameFnArgsDoc fnArgsDoc + (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc renameDocumentation :: Documentation Name -> RnM (Documentation DocName) renameDocumentation (Documentation mDoc mWarning) = - Documentation `fmap` mapM renameDoc mDoc `ap` mapM renameDoc mWarning + Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -- cgit v1.2.3