aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Terei <davidterei@gmail.com>2011-08-18 14:27:53 -0700
committerDavid Terei <davidterei@gmail.com>2011-10-12 14:02:55 -0700
commit45bcf701d8e99e86f28a966b31654c16a5ae6b42 (patch)
tree0a87147ec4e11353f8d0850a39d5d09aa4a457e5
parent8b2ee333020aeb9e639cd1772e1dca3b4b4ef3d2 (diff)
Add safe haskell indication to haddock output
-rw-r--r--src/Haddock/Backends/Xhtml.hs3
-rw-r--r--src/Haddock/Interface/LexParseRn.hs27
-rw-r--r--src/Haddock/Interface/ParseModuleHeader.hs3
-rw-r--r--src/Haddock/Interface/Rn.hs5
-rw-r--r--src/Haddock/InterfaceFile.hs4
-rw-r--r--src/Haddock/Types.hs2
6 files changed, 28 insertions, 16 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index b639760d..08e2fe07 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 a92c9c46..d013ca27 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 d0e3e5fb..35533d0d 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 6f7af908..d63524b6 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 57374b1d..8ff91e34 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 fddafc1d..c9b29bd0 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
}