From d54959189f33105ed09a59efee5ba34f53369282 Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Thu, 11 Aug 2011 12:08:15 +0100
Subject: Hack this to make it work with both Alex 2.x and Alex 3.x.  Unicode
 in documentation strings is (still) mangled.  I don't think it's possible to
 make it so that we get the current behaviour with Alex 2.x but magic Unicode
 support if you use Alex 3.x.  At some point we have to decide that Alex 3.x
 is a requirement, then we can do Unicode.

---
 src/Haddock/Lex.x | 34 ++++++++++++++++++++++++++++++++--
 1 file changed, 32 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x
index 17267656..e41c9461 100644
--- a/src/Haddock/Lex.x
+++ b/src/Haddock/Lex.x
@@ -31,12 +31,11 @@ import DynFlags
 import FastString
 
 import Data.Char
+import Data.Word (Word8)
 import Numeric
 import System.IO.Unsafe
 }
 
-%wrapper "posn"
-
 $ws    = $white # \n
 $digit = [0-9]
 $hexdigit = [0-9a-fA-F]
@@ -140,6 +139,37 @@ tokenPos t = let AlexPn _ line col = snd t in (line, col)
 -- -----------------------------------------------------------------------------
 -- Alex support stuff
 
+-- XXX: copied the posn wrapper code from Alex to make this lexer work
+-- with both Alex 2.x and Alex 3.x.  However, we are not using the
+-- Unicode/UTF-8 support in Alex 3.x, and Unicode documentation will
+-- probably get mangled.
+
+type AlexInput = (AlexPosn,     -- current position,
+                  Char,         -- previous char
+                  String)       -- current input string
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p,c,s) = c
+
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (p,c,[]) = Nothing
+alexGetByte (p,_,(c:s))  = let p' = alexMove p c
+                              in p' `seq`  Just (fromIntegral (ord c), (p', c, s))
+
+-- for compat with Alex 2.x:
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar i = case alexGetByte i of
+                  Nothing     -> Nothing
+                  Just (b,i') -> Just (chr (fromIntegral b), i')
+
+alexMove :: AlexPosn -> Char -> AlexPosn
+alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1
+alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)
+
+data AlexPosn = AlexPn !Int !Int !Int
+        deriving (Eq,Show)
+
 type StartCode = Int
 type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken]
 
-- 
cgit v1.2.3


From 6fd172c2692723ab67fcc1a998feed320a8ab144 Mon Sep 17 00:00:00 2001
From: Max Bolingbroke <batterseapower@hotmail.com>
Date: Mon, 22 Aug 2011 20:25:27 +0100
Subject: Adapt Haddock for the ConstraintKind extension changes

---
 src/Haddock/Backends/Hoogle.hs           |  4 +-
 src/Haddock/Backends/LaTeX.hs            | 31 ++++++-------
 src/Haddock/Backends/Xhtml/Decl.hs       | 32 ++++++--------
 src/Haddock/Convert.hs                   | 75 +++++++++++++++-----------------
 src/Haddock/Interface/AttachInstances.hs |  2 -
 src/Haddock/Interface/Create.hs          |  2 +-
 src/Haddock/Interface/Rename.hs          | 31 +++----------
 src/Haddock/Types.hs                     |  2 +-
 8 files changed, 73 insertions(+), 106 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 44e83d64..adf95636 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -143,10 +143,10 @@ ppClass x = out x{tcdSigs=[]} :
         addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
         addContext _ = error "expected TypeSig"
 
-        f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d
+        f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
         f t = HsForAllTy Implicit [] (reL [context]) (reL t)
 
-        context = reL $ HsClassP (unL $ tcdLName x)
+        context = nlHsTyConApp (unL $ tcdLName x)
             (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))
 
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 27f6bd5e..59fff6ae 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import GHC
 import OccName
 import Name                 ( isTyConName, nameOccName )
 import RdrName              ( rdrNameOcc, isRdrTc )
-import BasicTypes           ( IPName(..), Boxity(..) )
+import BasicTypes           ( ipNameName )
 import Outputable           ( Outputable, ppr, showSDoc )
 import FastString           ( unpackFS, unpackLitString )
 
@@ -450,7 +450,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
            -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
            -> Bool -> LaTeX
 ppClassHdr summ lctxt n tvs fds unicode =
@@ -771,7 +771,7 @@ ppContextNoArrow []  _ = empty
 ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
 
 
-ppContextNoLocs :: [HsPred DocName] -> Bool -> LaTeX
+ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
 ppContextNoLocs []  _ = empty
 ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
 
@@ -780,17 +780,10 @@ ppContext :: HsContext DocName -> Bool -> LaTeX
 ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
 
 
-pp_hs_context :: [HsPred DocName] -> Bool -> LaTeX
+pp_hs_context :: [HsType DocName] -> Bool -> LaTeX
 pp_hs_context []  _       = empty
-pp_hs_context [p] unicode = ppPred unicode p
-pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)
-
-
-ppPred :: Bool -> HsPred DocName -> LaTeX
-ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode
-ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <> text "~" <> ppLType unicode t2
-ppPred unicode (HsIParam (IPName n) t)
-  = char '?' <> ppDocName n <> dcolon unicode <> ppLType unicode t
+pp_hs_context [p] unicode = ppType unicode p
+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
 
 
 -------------------------------------------------------------------------------
@@ -807,9 +800,9 @@ ppBang HsNoBang = empty
 ppBang _        = char '!' -- Unpacked args is an implementation detail,
 
 
-tupleParens :: Boxity -> [LaTeX] -> LaTeX
-tupleParens Boxed   = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
+tupleParens (HsBoxyTuple _) = parenList
+tupleParens HsUnboxedTuple  = ubxParenList
 
 
 -------------------------------------------------------------------------------
@@ -878,12 +871,16 @@ ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) t
 ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind)
 ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _         (HsPredTy p)        u = parens (ppPred u p)
+ppr_mono_ty _         (HsIParamTy n ty)   u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty _         (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
 ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"
 
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index add926ab..eb1219f4 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,9 +32,9 @@ import qualified Data.Map as Map
 import           Data.Maybe
 import           Text.XHtml hiding     ( name, title, p, quote )
 
-import BasicTypes            ( IPName(..), Boxity(..) )
 import GHC
 import Name
+import BasicTypes            ( ipNameName )
 import Outputable            ( ppr, showSDoc, Outputable )
 
 
@@ -301,7 +301,7 @@ ppContextNoArrow []  _       _     = noHtml
 ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual
 
 
-ppContextNoLocs :: [HsPred DocName] -> Bool -> Qualification -> Html
+ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html
 ppContextNoLocs []  _       _     = noHtml
 ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual 
     <+> darrow unicode
@@ -311,18 +311,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html
 ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
 
 
-pp_hs_context :: [HsPred DocName] -> Bool -> Qualification-> Html
+pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html
 pp_hs_context []  _       _     = noHtml
-pp_hs_context [p] unicode qual = ppPred unicode qual p
-pp_hs_context cxt unicode qual = parenList (map (ppPred unicode qual) cxt)
-
-
-ppPred :: Bool -> Qualification -> HsPred DocName -> Html
-ppPred unicode qual (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode qual
-ppPred unicode qual (HsEqualP t1 t2) = ppLType unicode qual t1 <+> toHtml "~"
-    <+> ppLType unicode qual t2
-ppPred unicode qual (HsIParam (IPName n) t)
-  = toHtml "?" +++ ppDocName qual n <+> dcolon unicode <+> ppLType unicode qual t
+pp_hs_context [p] unicode qual = ppType unicode qual p
+pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt)
 
 
 -------------------------------------------------------------------------------
@@ -330,7 +322,7 @@ ppPred unicode qual (HsIParam (IPName n) t)
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
            -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]
            -> Bool -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
@@ -653,9 +645,9 @@ ppBang _        = toHtml "!" -- Unpacked args is an implementation detail,
                              -- so we just show the strictness annotation
 
 
-tupleParens :: Boxity -> [Html] -> Html
-tupleParens Boxed   = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [Html] -> Html
+tupleParens (HsBoxyTuple _) = parenList
+tupleParens HsUnboxedTuple  = ubxParenList
 
 
 --------------------------------------------------------------------------------
@@ -724,7 +716,7 @@ ppr_mono_ty _         (HsKindSig ty kind) u q =
     parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppKind kind)
 ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _         (HsPredTy p)        u q = parens (ppPred u q p)
+ppr_mono_ty _         (HsIParamTy n ty)   u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)
 ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"
 #if __GLASGOW_HASKELL__ == 612
 ppr_mono_ty _         (HsSpliceTyOut {})  _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
@@ -734,6 +726,10 @@ ppr_mono_ty _         (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteT
 ppr_mono_ty _         (HsRecTy {})        _ _ = error "ppr_mono_ty HsRecTy"
 ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"
 
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 34de6775..b3549fdc 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,14 +20,16 @@ module Haddock.Convert where
 import HsSyn
 import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy )
 import TypeRep
+import Kind ( liftedTypeKind, constraintKind )
 import Coercion ( splitKindFunTys, synTyConResKind )
 import Name
 import Var
 import Class
 import TyCon
 import DataCon
+import BasicTypes ( TupleSort(..) )
 import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName )
+import TysWiredIn ( listTyConName, eqTyCon )
 import Bag ( emptyBag )
 import SrcLoc ( Located, noLoc, unLoc )
 
@@ -47,7 +49,22 @@ tyThingToLHsDecl t = noLoc $ case t of
 
   -- type-constructors (e.g. Maybe) are complicated, put the definition
   -- later in the file (also it's used for class associated-types too.)
-  ATyCon tc -> TyClD (synifyTyCon tc)
+  ATyCon tc
+    | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
+    -> TyClD $ ClassDecl
+         (synifyCtx (classSCTheta cl))
+         (synifyName cl)
+         (synifyTyVars (classTyVars cl))
+         (map (\ (l,r) -> noLoc
+                    (map getName l, map getName r) ) $
+            snd $ classTvsFds cl)
+         (map (noLoc . synifyIdSig DeleteTopLevelQuantification)
+              (classMethods cl))
+         emptyBag --ignore default method definitions, they don't affect signature
+         (map synifyClassAT (classATs cl))
+         [] --we don't have any docs at this point
+    | otherwise
+    -> TyClD (synifyTyCon tc)
 
   -- type-constructors (e.g. Maybe) are complicated, put the definition
   -- later in the file (also it's used for class associated-types too.)
@@ -56,20 +73,6 @@ tyThingToLHsDecl t = noLoc $ case t of
   -- a data-constructor alone just gets rendered as a function:
   ADataCon dc -> SigD (TypeSig [synifyName dc]
     (synifyType ImplicitizeForAll (dataConUserType dc)))
-  -- classes are just a little tedious
-  AClass cl ->
-    TyClD $ ClassDecl
-      (synifyCtx (classSCTheta cl))
-      (synifyName cl)
-      (synifyTyVars (classTyVars cl))
-      (map (\ (l,r) -> noLoc
-                 (map getName l, map getName r) ) $
-         snd $ classTvsFds cl)
-      (map (noLoc . synifyIdSig DeleteTopLevelQuantification)
-           (classMethods cl))
-      emptyBag --ignore default method definitions, they don't affect signature
-      (map synifyClassAT (classATs cl))
-      [] --we don't have any docs at this point
 
 
 -- class associated-types are a subset of TyCon
@@ -224,25 +227,7 @@ synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
 
 
 synifyCtx :: [PredType] -> LHsContext Name
-synifyCtx = noLoc . map synifyPred
-
-
-synifyPred :: PredType -> LHsPred Name
-synifyPred (ClassP cls tys) =
-    let sTys = map (synifyType WithinType) tys
-    in noLoc $
-        HsClassP (getName cls) sTys
-synifyPred (IParam ip ty) =
-    let sTy = synifyType WithinType ty
-    -- IPName should be in class NamedThing...
-    in noLoc $
-      HsIParam ip sTy
-synifyPred (EqPred ty1 ty2) =
-    let
-     s1 = synifyType WithinType ty1
-     s2 = synifyType WithinType ty2
-    in noLoc $
-      HsEqualP s1 s2
+synifyCtx = noLoc . map (synifyType WithinType)
 
 
 synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]
@@ -273,16 +258,26 @@ data SynifyTypeState
 
 
 synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (PredTy{}) = --should never happen.
-  error "synifyType: PredTys are not, in themselves, source-level types."
 synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
 synifyType _ (TyConApp tc tys)
   -- Use non-prefix tuple syntax where possible, because it looks nicer.
   | isTupleTyCon tc, tyConArity tc == length tys =
-     noLoc $ HsTupleTy (tupleTyConBoxity tc) (map (synifyType WithinType) tys)
+     noLoc $ HsTupleTy (case tupleTyConSort tc of
+                          BoxedTuple   -> HsBoxyTuple liftedTypeKind
+                          FactTuple    -> HsBoxyTuple constraintKind
+                          UnboxedTuple -> HsUnboxedTuple)
+                       (map (synifyType WithinType) tys)
   -- ditto for lists
   | getName tc == listTyConName, [ty] <- tys =
      noLoc $ HsListTy (synifyType WithinType ty)
+  -- ditto for implicit parameter tycons
+  | Just ip <- tyConIP_maybe tc
+  , [ty] <- tys
+  = noLoc $ HsIParamTy ip (synifyType WithinType ty)
+  -- and equalities
+  | tc == eqTyCon
+  , [ty1, ty2] <- tys
+  = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
   -- Most TyCons:
   | otherwise =
     foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
@@ -313,9 +308,9 @@ synifyType s forallty@(ForAllTy _tv _ty) =
 
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) ->
-                  ([HsPred Name], Name, [HsType Name])
+                  ([HsType Name], Name, [HsType Name])
 synifyInstHead (_, preds, cls, ts) =
-  ( map (unLoc . synifyPred) preds
+  ( map (unLoc . synifyType WithinType) preds
   , getName cls
   , map (unLoc . synifyType WithinType) ts
   )
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index e4da3233..01d5b0f4 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -116,7 +116,6 @@ getAllInfo name = withSession $ \hsc_env -> do
 data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
 
 
--- TODO: should we support PredTy here?
 instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
 instHead (_, _, cls, args)
   = (map argCount args, className cls, map simplify args)
@@ -134,7 +133,6 @@ instHead (_, _, cls, args)
       where (SimpleType s ts) = simplify t1
     simplify (TyVarTy v) = SimpleType (tyVarName v) []
     simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
-    simplify _ = error "simplify"
 
 
 -- sortImage f = sortBy (\x y -> compare (f x) (f y))
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f9d72bd0..860a0044 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -770,7 +770,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
   _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))
   where
     lctxt = noLoc . ctxt
-    ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds
+    ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
 extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
 
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 2d5c899a..cc49cd53 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -17,8 +17,8 @@ import Haddock.GhcUtils
 
 import GHC hiding (NoLink)
 import Name
-import BasicTypes
 import Bag (emptyBag)
+import BasicTypes ( IPName(..), ipNameName )
 
 import Data.List
 import qualified Data.Map as Map hiding ( Map )
@@ -208,25 +208,6 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
 renameFnArgsDoc = mapM renameDoc
 
 
-renameLPred :: LHsPred Name -> RnM (LHsPred DocName)
-renameLPred = mapM renamePred
-
-
-renamePred :: HsPred Name -> RnM (HsPred DocName)
-renamePred (HsClassP name types) = do
-  name'  <- rename name
-  types' <- mapM renameLType types
-  return (HsClassP name' types')
-renamePred (HsEqualP type1 type2) = do
-  type1' <- renameLType type1
-  type2' <- renameLType type2
-  return (HsEqualP type1' type2')
-renamePred (HsIParam (IPName name) t) = do
-  name' <- rename name
-  t'    <- renameLType t
-  return (HsIParam (IPName name') t')
-
-
 renameLType :: LHsType Name -> RnM (LHsType DocName)
 renameLType = mapM renameType
 
@@ -254,6 +235,8 @@ renameType t = case t of
 
   HsListTy ty -> return . HsListTy =<< renameLType ty
   HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
+  HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)
+  HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
 
@@ -265,8 +248,6 @@ renameType t = case t of
 
   HsParTy ty -> return . HsParTy =<< renameLType ty
 
-  HsPredTy p -> return . HsPredTy =<< renamePred p
-
   HsKindSig ty k -> do
     ty' <- renameLType ty
     return (HsKindSig ty' k)
@@ -285,15 +266,15 @@ renameLTyVarBndr (L loc tv) = do
   return $ L loc (replaceTyVarName tv name')
 
 
-renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName])
+renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
 renameLContext (L loc context) = do
-  context' <- mapM renameLPred context
+  context' <- mapM renameLType context
   return (L loc context')
 
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
 renameInstHead (preds, className, types) = do
-  preds' <- mapM renamePred preds
+  preds' <- mapM renameType preds
   className' <- rename className
   types' <- mapM renameType types
   return (preds', className', types')
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index d82e3efd..fddafc1d 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -259,7 +259,7 @@ type DocInstance name = (InstHead name, Maybe (Doc name))
 
 -- | The head of an instance. Consists of a context, a class name and a list
 -- of instance types.
-type InstHead name = ([HsPred name], name, [HsType name])
+type InstHead name = ([HsType name], name, [HsType name])
 
 
 -----------------------------------------------------------------------------
-- 
cgit v1.2.3


From 0f21c474382af69bb7dac214d6c225218240e033 Mon Sep 17 00:00:00 2001
From: Max Bolingbroke <batterseapower@hotmail.com>
Date: Tue, 6 Sep 2011 09:13:59 +0100
Subject: Ignore associated type defaults (just as we ignore default methods)

---
 src/Haddock/Backends/LaTeX.hs      |  6 +++---
 src/Haddock/Backends/Xhtml/Decl.hs |  4 ++--
 src/Haddock/Convert.hs             | 13 ++++++++++---
 src/Haddock/Interface/Rename.hs    |  5 +++--
 4 files changed, 18 insertions(+), 10 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 27f6bd5e..a6e1bcdc 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -473,7 +473,7 @@ ppClassDecl :: [DocInstance DocName] -> SrcSpan
             -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
             -> TyClDecl DocName -> Bool -> LaTeX
 ppClassDecl instances loc mbDoc subdocs
-  (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
+  (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode
   = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
     instancesBit
   where
@@ -486,8 +486,8 @@ ppClassDecl instances loc mbDoc subdocs
     body = catMaybes [fmap docToLaTeX mbDoc, body_]
 
     body_
-      | null lsigs, null ats = Nothing
-      | null ats  = Just methodTable
+      | null lsigs, null ats, null at_defs = Nothing
+      | null ats, null at_defs = Just methodTable
 ---     | otherwise = atTable $$ methodTable
       | otherwise = error "LaTeX.ppClassDecl"
 
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index add926ab..16e32b7e 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -352,7 +352,7 @@ ppFds fds unicode qual =
 ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
                  -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
                  -> Html
-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc
     subdocs unicode qual = 
   if null sigs && null ats
     then (if summary then id else topDeclElem links loc [nm]) hdr
@@ -381,7 +381,7 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
             -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)]
             -> TyClDecl DocName -> Bool -> Qualification -> Html
 ppClassDecl summary links instances loc mbDoc subdocs
-        decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode qual
+        decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual
   | summary = ppShortClassDecl summary links decl loc subdocs unicode qual
   | otherwise = classheader +++ maybeDocSection qual mbDoc
                   +++ atBit +++ methodBit  +++ instancesBit
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 34de6775..81435a6e 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -68,14 +68,21 @@ tyThingToLHsDecl t = noLoc $ case t of
       (map (noLoc . synifyIdSig DeleteTopLevelQuantification)
            (classMethods cl))
       emptyBag --ignore default method definitions, they don't affect signature
-      (map synifyClassAT (classATs cl))
+      ats
+      (concat at_defss)
       [] --we don't have any docs at this point
+    where (ats, at_defss) = unzip $ map synifyClassAT (classATItems cl)
 
 
 -- class associated-types are a subset of TyCon
 -- (mainly only type/data-families)
-synifyClassAT :: TyCon -> LTyClDecl Name
-synifyClassAT = noLoc . synifyTyCon
+synifyClassAT :: ClassATItem -> (LTyClDecl Name, [LTyClDecl Name])
+synifyClassAT (tc, _mb_defs) = (noLoc (synifyTyCon tc), [])
+  -- ignore the mb_defs since we ignore default methods
+
+synifyATDefault :: TyCon -> LTyClDecl Name
+synifyATDefault tc = noLoc (synifyAxiom ax)
+  where Just ax = tyConFamilyCoercion_maybe tc
 
 synifyAxiom :: CoAxiom -> TyClDecl Name
 synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 2d5c899a..70520028 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -351,15 +351,16 @@ renameTyClD d = case d of
     typats'  <- mapM (mapM renameLType) typats
     return (TySynonym lname' ltyvars' typats' ltype')
 
-  ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do
+  ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do
     lcontext' <- renameLContext lcontext
     lname'    <- renameL lname
     ltyvars'  <- mapM renameLTyVarBndr ltyvars
     lfundeps' <- mapM renameLFunDep lfundeps
     lsigs'    <- mapM renameLSig lsigs
     ats'      <- mapM renameLTyClD ats
+    at_defs'  <- mapM renameLTyClD at_defs
     -- we don't need the default methods or the already collected doc entities
-    return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' [])
+    return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' [])
 
   where
     renameLCon (L loc con) = return . L loc =<< renameCon con
-- 
cgit v1.2.3


From ebb07175062cf5122f3c49fa025163a9d6392e63 Mon Sep 17 00:00:00 2001
From: Max Bolingbroke <batterseapower@hotmail.com>
Date: Fri, 9 Sep 2011 14:10:40 +0100
Subject: Replace FactTuple with ConstraintTuple

---
 src/Haddock/Convert.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index d4f75662..e46a37a4 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -263,9 +263,9 @@ synifyType _ (TyConApp tc tys)
   -- Use non-prefix tuple syntax where possible, because it looks nicer.
   | isTupleTyCon tc, tyConArity tc == length tys =
      noLoc $ HsTupleTy (case tupleTyConSort tc of
-                          BoxedTuple   -> HsBoxyTuple liftedTypeKind
-                          FactTuple    -> HsBoxyTuple constraintKind
-                          UnboxedTuple -> HsUnboxedTuple)
+                          BoxedTuple      -> HsBoxyTuple liftedTypeKind
+                          ConstraintTuple -> HsBoxyTuple constraintKind
+                          UnboxedTuple    -> HsUnboxedTuple)
                        (map (synifyType WithinType) tys)
   -- ditto for lists
   | getName tc == listTyConName, [ty] <- tys =
-- 
cgit v1.2.3


From 006e0c13d7885cc446b6d58aa256a3574d4349e8 Mon Sep 17 00:00:00 2001
From: Max Bolingbroke <batterseapower@hotmail.com>
Date: Mon, 12 Sep 2011 22:28:28 +0100
Subject: Follow changes to BinIface Name serialization

---
 src/Haddock/InterfaceFile.hs | 55 ++++++++++++++++++++++++++++----------------
 src/Main.hs                  |  4 +++-
 2 files changed, 38 insertions(+), 21 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index d337eefe..57374b1d 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RankNTypes #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
@@ -30,6 +31,7 @@ import Data.Map (Map)
 
 import GHC hiding (NoLink)
 import Binary
+import BinIface (getSymtabName, getDictFastString)
 import Name
 import UniqSupply
 import UniqFM
@@ -108,10 +110,10 @@ writeInterfaceFile filename iface = do
   let bin_dict = BinDictionary {
                       bin_dict_next = dict_next_ref,
                       bin_dict_map  = dict_map_ref }
-  ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
 
   -- put the main thing
-  bh <- return $ setUserData bh0 ud
+  bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab)
+                                                 (putFastString bin_dict)
   put_ bh iface
 
   -- write the symtab pointer at the front of the file
@@ -170,9 +172,11 @@ freshNameCache = ( create_fresh_nc , \_ -> return () )
 -- monad being used.  The exact monad is whichever monad the first
 -- argument, the getter and setter of the name cache, requires.
 --
-readInterfaceFile :: MonadIO m =>
-                     NameCacheAccessor m
-                  -> FilePath -> m (Either String InterfaceFile)
+readInterfaceFile :: forall m.
+                     MonadIO m
+                  => NameCacheAccessor m
+                  -> FilePath
+                  -> m (Either String InterfaceFile)
 readInterfaceFile (get_name_cache, set_name_cache) filename = do
   bh0 <- liftIO $ readBinMem filename
 
@@ -184,23 +188,38 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
       "Magic number mismatch: couldn't load interface file: " ++ filename
       | version /= binaryInterfaceVersion -> return . Left $
       "Interface file is of wrong version: " ++ filename
-      | otherwise -> do
+      | otherwise -> with_name_cache $ \update_nc -> do
 
       dict  <- get_dictionary bh0
-      bh1   <- init_handle_user_data bh0 dict
-
-      theNC <- get_name_cache
-      (nc', symtab) <- get_symbol_table bh1 theNC
-      set_name_cache nc'
-
-      -- set the symbol table
-      let ud' = getUserData bh1
-      bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab}
+  
+      -- read the symbol table so we are capable of reading the actual data
+      bh1 <- do
+          let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
+                                                   (getDictFastString dict)
+          symtab <- update_nc (get_symbol_table bh1)
+          return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)
+                                                  (getDictFastString dict)
 
       -- load the actual data
-      iface <- liftIO $ get bh2
+      iface <- liftIO $ get bh1
       return (Right iface)
  where
+   with_name_cache :: forall a.
+                      ((forall n b. MonadIO n
+                                => (NameCache -> n (NameCache, b))
+                                -> n b)
+                       -> m a)
+                   -> m a
+   with_name_cache act = do
+      nc_var <-  get_name_cache >>= (liftIO . newIORef)
+      x <- act $ \f -> do
+              nc <- liftIO $ readIORef nc_var
+              (nc', x) <- f nc
+              liftIO $ writeIORef nc_var nc'
+              return x
+      liftIO (readIORef nc_var) >>= set_name_cache
+      return x
+
    get_dictionary bin_handle = liftIO $ do
       dict_p <- get bin_handle
       data_p <- tellBin bin_handle
@@ -209,10 +228,6 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
       seekBin bin_handle data_p
       return dict
 
-   init_handle_user_data bin_handle dict = liftIO $ do
-      ud <- newReadState dict
-      return (setUserData bin_handle ud)
-
    get_symbol_table bh1 theNC = liftIO $ do
       symtab_p <- get bh1
       data_p'  <- tellBin bh1
diff --git a/src/Main.hs b/src/Main.hs
index b49fc6e4..6e029b99 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -60,6 +60,8 @@ import DynFlags hiding (flags, verbosity)
 import Panic (panic, handleGhcException)
 import Module
 
+import Control.Monad.Fix (MonadFix)
+
 
 --------------------------------------------------------------------------------
 -- * Exception handling
@@ -251,7 +253,7 @@ render flags ifaces installedIfaces srcMap = do
 -------------------------------------------------------------------------------
 
 
-readInterfaceFiles :: MonadIO m =>
+readInterfaceFiles :: (MonadFix m, MonadIO m) =>
                       NameCacheAccessor m
                    -> [(DocPaths, FilePath)] ->
                       m [(DocPaths, InterfaceFile)]
-- 
cgit v1.2.3


From 8b2ee333020aeb9e639cd1772e1dca3b4b4ef3d2 Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Sat, 1 Oct 2011 01:34:06 +0100
Subject: Follow changes to ForeignImport/ForeignExport in GHC

---
 src/Haddock/Backends/Hoogle.hs            | 4 ++--
 src/Haddock/Backends/Xhtml/Decl.hs        | 2 +-
 src/Haddock/GhcUtils.hs                   | 4 ++--
 src/Haddock/Interface/Create.hs           | 2 +-
 src/Haddock/Interface/ExtractFnArgDocs.hs | 2 +-
 src/Haddock/Interface/Rename.hs           | 8 ++++----
 6 files changed, 11 insertions(+), 11 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index adf95636..45399963 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -114,8 +114,8 @@ ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
         f (TyClD d@TyData{}) = ppData d subdocs
         f (TyClD d@ClassDecl{}) = ppClass d
         f (TyClD d@TySynonym{}) = ppSynonym d
-        f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ
-        f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ
+        f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ
+        f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ
         f (SigD sig) = ppSig sig
         f _ = []
 ppExport _ = []
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 28132046..c1f3a89a 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -114,7 +114,7 @@ tyvarNames = map (getName . hsTyVarName . unLoc)
 
 ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
       -> ForeignDecl DocName -> Bool -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode qual
   = ppFunSig summary links loc doc [name] typ unicode qual
 ppFor _ _ _ _ _ _ _ = error "ppFor"
 
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index f79acd94..33ae1b6d 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -96,8 +96,8 @@ getMainDeclBinder (ValD d) =
 #endif
 
 getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name]
-getMainDeclBinder (ForD (ForeignExport _ _ _)) = []
+getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
+getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
 getMainDeclBinder _ = []
 
 -- Useful when there is a signature with multiple names, e.g.
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 860a0044..057fceb7 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -263,7 +263,7 @@ declsFromClass class_ = docs ++ defs ++ sigs ++ ats
 
 declNames :: HsDecl a -> [a]
 declNames (TyClD d) = [tcdName d]
-declNames (ForD (ForeignImport n _ _)) = [unLoc n]
+declNames (ForD (ForeignImport n _ _ _)) = [unLoc n]
 -- we have normal sigs only (since they are taken from ValBindsOut)
 declNames (SigD sig) = sigNameNoLoc sig
 declNames _ = error "unexpected argument to declNames"
diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs
index 8889c3ab..a9f8a807 100644
--- a/src/Haddock/Interface/ExtractFnArgDocs.hs
+++ b/src/Haddock/Interface/ExtractFnArgDocs.hs
@@ -24,7 +24,7 @@ import GHC
 
 getDeclFnArgDocs :: HsDecl Name -> Map Int HsDocString
 getDeclFnArgDocs (SigD (TypeSig _ ty)) = getTypeFnArgDocs ty
-getDeclFnArgDocs (ForD (ForeignImport _ ty _)) = getTypeFnArgDocs ty
+getDeclFnArgDocs (ForD (ForeignImport _ ty _ _)) = getTypeFnArgDocs ty
 getDeclFnArgDocs (TyClD (TySynonym {tcdSynRhs = ty})) = getTypeFnArgDocs ty
 getDeclFnArgDocs _ = Map.empty
 
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 4ea22a2e..546ba62b 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -392,14 +392,14 @@ renameSig sig = case sig of
 
 
 renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
-renameForD (ForeignImport lname ltype x) = do
+renameForD (ForeignImport lname ltype co x) = do
   lname' <- renameL lname
   ltype' <- renameLType ltype
-  return (ForeignImport lname' ltype' x)
-renameForD (ForeignExport lname ltype x) = do
+  return (ForeignImport lname' ltype' co x)
+renameForD (ForeignExport lname ltype co x) = do
   lname' <- renameL lname
   ltype' <- renameLType ltype
-  return (ForeignExport lname' ltype' x)
+  return (ForeignExport lname' ltype' co x)
 
 
 renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
-- 
cgit v1.2.3


From 45bcf701d8e99e86f28a966b31654c16a5ae6b42 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/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(-)

(limited to 'src')

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
   }
 
 
-- 
cgit v1.2.3