Repository : ssh://darcs.haskell.org//srv/darcs/haddock On branch : master
http://hackage.haskell.org/trac/ghc/changeset/45bcf701d8e99e86f28a966b31654c16a5ae6b42 >--------------------------------------------------------------- commit 45bcf701d8e99e86f28a966b31654c16a5ae6b42 Author: David Terei <[email protected]> Date: Thu Aug 18 14:27:53 2011 -0700 Add safe haskell indication to haddock output >--------------------------------------------------------------- src/Haddock/Backends/Xhtml.hs | 3 ++- src/Haddock/Interface/LexParseRn.hs | 27 ++++++++++++++++----------- src/Haddock/Interface/ParseModuleHeader.hs | 3 ++- src/Haddock/Interface/Rn.hs | 5 +++-- src/Haddock/InterfaceFile.hs | 4 +++- src/Haddock/Types.hs | 2 ++ 6 files changed, 28 insertions(+), 16 deletions(-) diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index b639760..08e2fe0 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -200,7 +200,8 @@ moduleInfo iface = entries = mapMaybe doOneEntry [ ("Portability",hmi_portability), ("Stability",hmi_stability), - ("Maintainer",hmi_maintainer) + ("Maintainer",hmi_maintainer), + ("Safe Haskell",hmi_safety) ] in case entries of diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index a92c9c4..d013ca2 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -25,6 +25,7 @@ import Haddock.Doc import Data.Maybe import FastString import GHC +import Outputable ( showPpr ) import RdrName data HaddockCommentType = NormalHaddockComment | DocSectionComment @@ -59,14 +60,18 @@ lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment df -- yes, you always get a HaddockModInfo though it might be empty lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) lexParseRnHaddockModHeader dflags gre mbStr = do - let failure = (emptyHaddockModInfo, Nothing) - case mbStr of - Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs - case parseModuleHeader dflags str of - Left mess -> do - tell ["haddock module header parse failed: " ++ mess] - return failure - Right (info, doc) -> - return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) + (hmod, docn) <- case mbStr of + Nothing -> return failure + Just (L _ (HsDocString fs)) -> do + let str = unpackFS fs + case parseModuleHeader dflags str of + Left mess -> do + tell ["haddock module header parse failed: " ++ mess] + return failure + Right (info, doc) -> + return (rnHaddockModInfo gre info, Just (rnDoc gre doc)) + return (hmod { hmi_safety = safety }, docn) + + where + safety = Just $ showPpr $ safeHaskell dflags + failure = (emptyHaddockModInfo, Nothing) diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index d0e3e5f..35533d0 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -59,7 +59,8 @@ parseModuleHeader dflags str0 = hmi_description = docOpt, hmi_portability = portabilityOpt, hmi_stability = stabilityOpt, - hmi_maintainer = maintainerOpt + hmi_maintainer = maintainerOpt, + hmi_safety = Nothing }, doc) -- | This function is how we read keys. diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs index 6f7af90..d63524b 100644 --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -9,8 +9,9 @@ import Name ( Name ) import Outputable ( ppr, showSDoc ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -rnHaddockModInfo gre (HaddockModInfo desc port stab maint) = - HaddockModInfo (fmap (rnDoc gre) desc) port stab maint +rnHaddockModInfo gre hmod = + let desc = hmi_description hmod + in hmod { hmi_description = fmap (rnDoc gre) desc } ids2string :: [RdrName] -> String ids2string [] = [] diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index 57374b1..8ff91e3 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -526,13 +526,15 @@ instance Binary name => Binary (HaddockModInfo name) where put_ bh (hmi_portability hmi) put_ bh (hmi_stability hmi) put_ bh (hmi_maintainer hmi) + put_ bh (hmi_safety hmi) get bh = do descr <- get bh porta <- get bh stabi <- get bh maint <- get bh - return (HaddockModInfo descr porta stabi maint) + safet <- get bh + return (HaddockModInfo descr porta stabi maint safet) instance Binary DocName where diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index fddafc1..c9b29bd 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -330,6 +330,7 @@ data HaddockModInfo name = HaddockModInfo , hmi_portability :: Maybe String , hmi_stability :: Maybe String , hmi_maintainer :: Maybe String + , hmi_safety :: Maybe String } @@ -339,6 +340,7 @@ emptyHaddockModInfo = HaddockModInfo , hmi_portability = Nothing , hmi_stability = Nothing , hmi_maintainer = Nothing + , hmi_safety = Nothing } _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
