Add safe haskell indication to haddock output

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 d337eefe..33f28d68 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -511,13 +511,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 d82e3efd..c0bf4ad7 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
   }