From 0c16f3b04aadd0cc22fedbf123bae6369d1c445e Mon Sep 17 00:00:00 2001
From: David Terei <davidterei@gmail.com>
Date: Thu, 18 Aug 2011 14:27:53 -0700
Subject: Add safe haskell indication to haddock output

---
 src/Haddock/Interface/LexParseRn.hs        | 27 ++++++++++++++++-----------
 src/Haddock/Interface/ParseModuleHeader.hs |  3 ++-
 src/Haddock/Interface/Rn.hs                |  5 +++--
 3 files changed, 21 insertions(+), 14 deletions(-)

(limited to 'src/Haddock/Interface')

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 []    = []
-- 
cgit v1.2.3