Merge Haddock comment support from ghc.haddock -- big patch

compiler/cmm/CmmLex.x

@@ -276,7 +276,7 @@ lexToken = do
   sc <- getLexState
   case alexScan inp sc of
     AlexEOF -> do let span = mkSrcSpan loc1 loc1
-		  setLastToken span 0
+		  setLastToken span 0 0
 		  return (L span CmmT_EOF)
     AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
     AlexSkip inp2 _ -> do
@@ -285,7 +285,7 @@ lexToken = do
     AlexToken inp2@(end,buf2) len t -> do
 	setInput inp2
 	let span = mkSrcSpan loc1 end
-	span `seq` setLastToken span len
+	span `seq` setLastToken span len len
 	t span buf len
 
 -- -----------------------------------------------------------------------------

compiler/deSugar/Check.lhs

@@ -151,7 +151,7 @@ untidy b (L loc p) = L loc (untidy' b p)
 
 untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) 
 untidy_con (InfixCon p1 p2) = InfixCon  (untidy_pars p1) (untidy_pars p2)
-untidy_con (RecCon bs)      = RecCon    [(f,untidy_pars p) | (f,p) <- bs]
+untidy_con (RecCon bs)      = RecCon    [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ]
 
 pars :: NeedPars -> WarningPat -> Pat Name
 pars True p = ParPat p
@@ -687,7 +687,7 @@ simplify_con con (RecCon fs)
   where
      -- pad out all the missing fields with WildPats.
     field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
-    all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
+    all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
 		     field_pats fs
        
     insertNm nm p [] = [(nm,p)]

compiler/deSugar/DsMeta.hs

@@ -289,12 +289,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98 _))
   = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
 	 repConstr con1 details }
-repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
   = do { addTyVarBinds tvs $ \bndrs -> do {
-             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
+             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
              ctxt' <- repContext ctxt;
              bndrs' <- coreList nameTyConName bndrs;
              rep2 forallCName [unC bndrs', unC ctxt', unC c']
@@ -815,8 +815,8 @@ repP (ConPatIn dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
          PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
-         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
-                            ; ps <- sequence $ map repLP (map snd pairs)
+         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
+                            ; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
                             ; fps' <- coreList fieldPatQTyConName fps
                             ; repPrec con_str fps' }
@@ -1192,8 +1192,8 @@ repConstr con (PrefixCon ps)
          arg_tys1 <- coreList strictTypeQTyConName arg_tys
          rep2 normalCName [unC con, unC arg_tys1]
 repConstr con (RecCon ips)
-    = do arg_vs   <- mapM lookupLOcc (map fst ips)
-         arg_tys  <- mapM repBangTy (map snd ips)
+    = do arg_vs   <- mapM lookupLOcc (map hsRecFieldId ips)
+         arg_tys  <- mapM repBangTy (map hsRecFieldArg ips)
          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
                               arg_vs arg_tys
          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys

compiler/deSugar/MatchCon.lhs

@@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where
 
 import {-# SOURCE #-} Match	( match )
 
-import HsSyn		( Pat(..), LPat, HsConDetails(..) )
+import HsSyn		( Pat(..), LPat, HsConDetails(..), HsRecField(..) )
 import DsBinds		( dsLHsBinds )
 import DataCon		( DataCon, dataConInstOrigArgTys, dataConEqSpec,
 			  dataConFieldLabels, dataConSourceArity )
@@ -132,7 +132,7 @@ conArgPats data_con arg_tys (RecCon rpats)
 	-- mk_pat picks a WildPat of the appropriate type for absent fields,
 	-- and the specified pattern for present fields
     mk_pat lbl arg_ty
-	= case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
+	= case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of
 	    (pat:pats) -> ASSERT( null pats ) unLoc pat
 	    []	       -> WildPat arg_ty
 \end{code}

compiler/hsSyn/Convert.lhs

@@ -128,8 +128,8 @@ cvtTop (ClassD ctxt cl tvs fds decs)
   = do	{ (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
 	; fds'  <- mapM cvt_fundep fds
 	; (binds', sigs') <- cvtBindsAndSigs decs
-	; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' []
-							     -- no ATs in TH^^
+	; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
+						    -- no ATs or docs in TH ^^ ^^
 	}
 
 cvtTop (InstanceD tys ty decs)
@@ -158,20 +158,20 @@ cvtConstr (NormalC c strtys)
   = do	{ c'   <- cNameL c 
 	; cxt' <- returnL []
 	; tys' <- mapM cvt_arg strtys
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 }
+	; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
 
 cvtConstr (RecC c varstrtys)
   = do 	{ c'    <- cNameL c 
 	; cxt'  <- returnL []
 	; args' <- mapM cvt_id_arg varstrtys
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 }
+	; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
 
 cvtConstr (InfixC st1 c st2)
   = do 	{ c' <- cNameL c 
 	; cxt' <- returnL []
 	; st1' <- cvt_arg st1
 	; st2' <- cvt_arg st2
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 }
+	; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
 
 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
@@ -181,8 +181,8 @@ cvtConstr (ForallC tvs ctxt con)
 	; tvs'  <- cvtTvs tvs
 	; ctxt' <- cvtContext ctxt
 	; case con' of
-	    ConDecl l _ [] (L _ []) x ResTyH98
-	      -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98
+	    ConDecl l _ [] (L _ []) x ResTyH98 _
+	      -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
 	    c -> panic "ForallC: Can't happen" }
 
 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
@@ -190,7 +190,7 @@ cvt_arg (NotStrict, ty) = cvtType ty
 
 cvt_id_arg (i, str, ty) = do { i' <- vNameL i
 			     ; ty' <- cvt_arg (str,ty)
-			     ; return (i', ty') }
+			     ; return (mkRecField i' ty') }
 
 cvtDerivs [] = return Nothing
 cvtDerivs cs = do { cs' <- mapM cvt_one cs
@@ -458,7 +458,7 @@ cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 
-cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') }
+cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField s' p') }
 
 -----------------------------------------------------------
 --	Types and type variables

compiler/hsSyn/HsBinds.lhs

@@ -439,13 +439,14 @@ sigForThisGroup ns sig
 	Just n  -> n `elemNameSet` ns
 
 sigName :: LSig name -> Maybe name
-sigName (L _ sig) = f sig
- where
-    f (TypeSig   n _)          = Just (unLoc n)
-    f (SpecSig   n _ _)        = Just (unLoc n)
-    f (InlineSig n _)          = Just (unLoc n)
-    f (FixSig (FixitySig n _)) = Just (unLoc n)
-    f other			= Nothing
+sigName (L _ sig) = sigNameNoLoc sig
+
+sigNameNoLoc :: Sig name -> Maybe name    
+sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
+sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
+sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
+sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
+sigNameNoLoc other		                = Nothing
 
 isFixityLSig :: LSig name -> Bool
 isFixityLSig (L _ (FixSig {})) = True

compiler/hsSyn/HsDecls.lhs

@@ -15,6 +15,7 @@ module HsDecls (
 	ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
 	CImportSpec(..), FoType(..),
 	ConDecl(..), ResType(..), LConDecl,	
+	DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..),
 	DeprecDecl(..),  LDeprecDecl,
 	HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
 	tcdName, tyClDeclNames, tyClDeclTyVars,
@@ -35,9 +36,10 @@ import {-# SOURCE #-}	HsExpr( HsExpr, pprExpr )
 import HsBinds		( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds,
 			  Sig(..), LSig, LFixitySig, pprLHsBinds,
 			  emptyValBindsIn, emptyValBindsOut )
-import HsPat		( HsConDetails(..), hsConArgs )
+import HsPat		( HsConDetails(..), hsConArgs, HsRecField(..) )
 import HsImpExp		( pprHsVar )
 import HsTypes
+import HsDoc		( HsDoc, LHsDoc, ppr_mbDoc )
 import NameSet          ( NameSet )
 import CoreSyn		( RuleName )
 import {- Kind parts of -} Type		( Kind, pprKind )
@@ -54,7 +56,6 @@ import FastString
 import Maybe            ( isJust )
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection[HsDecl]{Declarations}
@@ -75,6 +76,8 @@ data HsDecl id
   | DeprecD	(DeprecDecl id)
   | RuleD	(RuleDecl id)
   | SpliceD	(SpliceDecl id)
+  | DocD	(DocDecl id)
+
 
 -- NB: all top-level fixity decls are contained EITHER
 -- EITHER SigDs
@@ -105,7 +108,11 @@ data HsGroup id
 	hs_defds  :: [LDefaultDecl id],
 	hs_fords  :: [LForeignDecl id],
 	hs_depds  :: [LDeprecDecl id],
-	hs_ruleds :: [LRuleDecl id]
+	hs_ruleds :: [LRuleDecl id],
+
+	hs_docs   :: [DocEntity id]
+                -- Used to remember the module structure,
+                -- which is needed to produce Haddock documentation
   }
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
@@ -115,7 +122,8 @@ emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }
 emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
 		       hs_fixds = [], hs_defds = [], hs_fords = [], 
 		       hs_depds = [], hs_ruleds = [],
-		       hs_valds = error "emptyGroup hs_valds: Can't happen" }
+		       hs_valds = error "emptyGroup hs_valds: Can't happen",
+                       hs_docs = [] }
 
 appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
 appendGroups 
@@ -128,7 +136,8 @@ appendGroups
 	hs_defds  = defds1,
 	hs_fords  = fords1, 
 	hs_depds  = depds1,
-	hs_ruleds = rulds1 }
+	hs_ruleds = rulds1,
+  hs_docs   = docs1 }
     HsGroup { 
 	hs_valds  = val_groups2,
 	hs_tyclds = tyclds2, 
@@ -138,7 +147,8 @@ appendGroups
 	hs_defds  = defds2,
 	hs_fords  = fords2, 
 	hs_depds  = depds2,
-	hs_ruleds = rulds2 }
+	hs_ruleds = rulds2,
+  hs_docs   = docs2 }
   = 
     HsGroup { 
 	hs_valds  = val_groups1 `plusHsValBinds` val_groups2,
@@ -149,21 +159,23 @@ appendGroups
 	hs_defds  = defds1 ++ defds2,
 	hs_fords  = fords1 ++ fords2, 
 	hs_depds  = depds1 ++ depds2,
-	hs_ruleds = rulds1 ++ rulds2 }
+	hs_ruleds = rulds1 ++ rulds2,
+  hs_docs   = docs1  ++ docs2 }
 \end{code}
 
 \begin{code}
 instance OutputableBndr name => Outputable (HsDecl name) where
-    ppr (TyClD dcl)  = ppr dcl
-    ppr (ValD binds) = ppr binds
-    ppr (DefD def)   = ppr def
-    ppr (InstD inst) = ppr inst
-    ppr (DerivD deriv) = ppr deriv
-    ppr (ForD fd)    = ppr fd
-    ppr (SigD sd)    = ppr sd
-    ppr (RuleD rd)   = ppr rd
-    ppr (DeprecD dd) = ppr dd
-    ppr (SpliceD dd) = ppr dd
+    ppr (TyClD dcl)             = ppr dcl
+    ppr (ValD binds)            = ppr binds
+    ppr (DefD def)              = ppr def
+    ppr (InstD inst)            = ppr inst
+    ppr (DerivD deriv)          = ppr deriv
+    ppr (ForD fd)               = ppr fd
+    ppr (SigD sd)               = ppr sd
+    ppr (RuleD rd)              = ppr rd
+    ppr (DeprecD dd)            = ppr dd
+    ppr (SpliceD dd)            = ppr dd
+    ppr (DocD doc)              = ppr doc
 
 instance OutputableBndr name => Outputable (HsGroup name) where
     ppr (HsGroup { hs_valds  = val_decls,
@@ -414,10 +426,11 @@ data TyClDecl name
 		tcdFDs     :: [Located (FunDep name)],	-- Functional deps
 		tcdSigs    :: [LSig name],		-- Methods' signatures
 		tcdMeths   :: LHsBinds name,		-- Default methods
-		tcdATs	   :: [LTyClDecl name]		-- Associated types; ie
+		tcdATs	   :: [LTyClDecl name],		-- Associated types; ie
 							--   only 'TyData',
 							--   'TyFunction',
 							--   and 'TySynonym'
+		tcdDocs    :: [DocEntity name]		-- Haddock docs
     }
 
 data NewOrData
@@ -638,6 +651,8 @@ data ConDecl name
     , con_details   :: HsConDetails name (LBangType name)	-- The main payload
 
     , con_res       :: ResType name         -- Result type of the constructor
+
+    , con_doc       :: Maybe (LHsDoc name)  -- A possible Haddock comment
     }
 
 data ResType name
@@ -657,7 +672,7 @@ conDeclsNames cons
     do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
 	= (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc)
 	where
-	  new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ]
+	  new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ]
 
     do_one (flds_seen, acc) c
 	= (flds_seen, (con_name c):acc)
@@ -670,23 +685,23 @@ conDetailsTys details = map getBangType (hsConArgs details)
 instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
-pprConDecl (ConDecl con expl tvs cxt details ResTyH98)
-  = sep [pprHsForAll expl tvs cxt, ppr_details con details]
+pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
+  = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
   where
     ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2]
     ppr_details con (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
     ppr_details con (RecCon fields)  = ppr con <+> ppr_fields fields
 
-pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty))
+pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
   = ppr con <+> dcolon <+> 
     sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
   where
     mk_fun_ty a b = noLoc (HsFunTy a b)
-pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty))
-  = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr fields <+> dcolon <+> ppr res_ty]
 
-ppr_fields fields = braces (sep (punctuate comma (map ppr_field fields)))
-ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
+pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
+  = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
+
+ppr_fields fields = braces (sep (punctuate comma (map ppr fields)))
 \end{code}
 
 %************************************************************************
@@ -909,6 +924,37 @@ instance OutputableBndr name => Outputable (RuleBndr name) where
    ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[DocDecl]{Document comments}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+-- source code entities, for representing the module structure
+data DocEntity name
+  = DeclEntity name
+  | DocEntity (DocDecl name)
+ 
+type LDocDecl name = Located (DocDecl name)
+
+data DocDecl name
+  = DocCommentNext (HsDoc name)
+  | DocCommentPrev (HsDoc name)
+  | DocCommentNamed String (HsDoc name)
+  | DocGroup Int (HsDoc name)
+ 
+-- Okay, I need to reconstruct the document comments, but for now:
+instance Outputable (DocDecl name) where
+  ppr _ = text "<document comment>"
+
+docDeclDoc (DocCommentNext d) = d
+docDeclDoc (DocCommentPrev d) = d
+docDeclDoc (DocCommentNamed _ d) = d
+docDeclDoc (DocGroup _ d) = d
+
+\end{code}
 
 %************************************************************************
 %*									*

compiler/hsSyn/HsDoc.hs

+module HsDoc (
+  HsDoc(..),
+  LHsDoc,
+  docAppend,
+  docParagraph,
+  ppr_mbDoc
+  ) where
+
+#include "HsVersions.h"
+
+import RdrName
+import Outputable
+import SrcLoc
+
+import Data.Char (isSpace)
+
+data HsDoc id
+  = DocEmpty
+  | DocAppend (HsDoc id) (HsDoc id)
+  | DocString String
+  | DocParagraph (HsDoc id)
+  | DocIdentifier [id]
+  | DocModule String
+  | DocEmphasis (HsDoc id)
+  | DocMonospaced (HsDoc id)
+  | DocUnorderedList [HsDoc id]
+  | DocOrderedList [HsDoc id]
+  | DocDefList [(HsDoc id, HsDoc id)]
+  | DocCodeBlock (HsDoc id)
+  | DocURL String
+  | DocAName String
+  deriving (Eq, Show)
+
+type LHsDoc a = Located (HsDoc a)
+
+instance Outputable (HsDoc a) where
+  ppr _ = text "<document comment>"
+
+ppr_mbDoc (Just doc) = ppr doc
+ppr_mbDoc Nothing    = empty
+
+-- used to make parsing easier; we group the list items later
+docAppend :: HsDoc id -> HsDoc id -> HsDoc id
+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
+  = DocUnorderedList (ds1++ds2)
+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
+  = DocAppend (DocUnorderedList (ds1++ds2)) d
+docAppend (DocOrderedList ds1) (DocOrderedList ds2)
+  = DocOrderedList (ds1++ds2)
+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
+  = DocAppend (DocOrderedList (ds1++ds2)) d
+docAppend (DocDefList ds1) (DocDefList ds2)
+  = DocDefList (ds1++ds2)
+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
+  = DocAppend (DocDefList (ds1++ds2)) d
+docAppend DocEmpty d = d
+docAppend d DocEmpty = d
+docAppend d1 d2
+  = DocAppend d1 d2
+
+-- again to make parsing easier - we spot a paragraph whose only item
+-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph :: HsDoc id -> HsDoc id
+docParagraph (DocMonospaced p)
+  = DocCodeBlock p
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+  | all isSpace s1
+  = DocCodeBlock p
+docParagraph (DocAppend (DocString s1)
+    (DocAppend (DocMonospaced p) (DocString s2)))
+  | all isSpace s1 && all isSpace s2
+  = DocCodeBlock p
+docParagraph (DocAppend (DocMonospaced p) (DocString s2))
+  | all isSpace s2
+  = DocCodeBlock p
+docParagraph p
+  = DocParagraph p

compiler/hsSyn/HsImpExp.lhs

@@ -9,6 +9,8 @@ module HsImpExp where
 #include "HsVersions.h"
 
 import Module		( ModuleName )
+import HsDoc		( HsDoc )
+
 import Outputable
 import FastString
 import SrcLoc		( Located(..) )
@@ -68,11 +70,14 @@ ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm
 type LIE name = Located (IE name)
 
 data IE name
-  = IEVar		name
-  | IEThingAbs          name		-- Class/Type (can't tell)
-  | IEThingAll          name		-- Class/Type plus all methods/constructors
-  | IEThingWith		name [name]	-- Class/Type plus some methods/constructors
-  | IEModuleContents    ModuleName	-- (Export Only)
+  = IEVar               name
+  | IEThingAbs          name		 -- Class/Type (can't tell)
+  | IEThingAll          name		 -- Class/Type plus all methods/constructors
+  | IEThingWith         name [name]	 -- Class/Type plus some methods/constructors
+  | IEModuleContents    ModuleName	 -- (Export Only)
+  | IEGroup             Int (HsDoc name) -- Doc section heading
+  | IEDoc               (HsDoc name)     -- Some documentation
+  | IEDocNamed          String           -- Reference to named doc
 \end{code}
 
 \begin{code}
@@ -88,6 +93,9 @@ ieNames (IEThingAbs       n   ) = [n]
 ieNames (IEThingAll       n   ) = [n]
 ieNames (IEThingWith      n ns) = n:ns
 ieNames (IEModuleContents _   ) = []
+ieNames (IEGroup          _ _ ) = []
+ieNames (IEDoc            _   ) = []
+ieNames (IEDocNamed       _   ) = []        
 \end{code}
 
 \begin{code}
@@ -99,6 +107,9 @@ instance (Outputable name) => Outputable (IE name) where
 	= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
     ppr (IEModuleContents mod)
 	= ptext SLIT("module") <+> ppr mod
+    ppr (IEGroup n doc)         = text ("<IEGroup: " ++ (show n) ++ ">") 
+    ppr (IEDoc doc)             = ppr doc
+    ppr (IEDocNamed string)     = text ("<IEDocNamed: " ++ string ++ ">")
 \end{code}
 
 \begin{code}

compiler/hsSyn/HsPat.lhs

@@ -8,6 +8,7 @@ module HsPat (
 	Pat(..), InPat, OutPat, LPat, 
 	
 	HsConDetails(..), hsConArgs,
+	HsRecField(..), mkRecField,
 
 	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
 
@@ -26,6 +27,7 @@ import HsBinds		( DictBinds, HsBind(..), HsWrapper, isIdHsWrapper, pprHsWrapper,
 			  emptyLHsBinds, pprLHsBinds )
 import HsLit		( HsLit(HsCharPrim), HsOverLit )
 import HsTypes		( LHsType, PostTcType )
+import HsDoc            ( LHsDoc, ppr_mbDoc )
 import BasicTypes	( Boxity, tupleParens )
 -- others:
 import PprCore		( {- instance OutputableBndr TyVar -} )
@@ -138,13 +140,21 @@ HsConDetails is use both for patterns and for data type declarations
 
 \begin{code}
 data HsConDetails id arg
-  = PrefixCon [arg]			-- C p1 p2 p3
-  | RecCon    [(Located id, arg)]	-- C { x = p1, y = p2 }
-  | InfixCon  arg arg			-- p1 `C` p2
+  = PrefixCon [arg]               -- C p1 p2 p3
+  | RecCon    [HsRecField id arg] -- C { x = p1, y = p2 }
+  | InfixCon  arg arg		  -- p1 `C` p2
+
+data HsRecField id arg = HsRecField {
+	hsRecFieldId  :: Located id,
+	hsRecFieldArg :: arg,
+	hsRecFieldDoc :: Maybe (LHsDoc id)
+}
+
+mkRecField id arg = HsRecField id arg Nothing
 
 hsConArgs :: HsConDetails id arg -> [arg]
 hsConArgs (PrefixCon ps)   = ps
-hsConArgs (RecCon fs)      = map snd fs
+hsConArgs (RecCon fs)      = map hsRecFieldArg fs
 hsConArgs (InfixCon p1 p2) = [p1,p2]
 \end{code}
 
@@ -209,13 +219,17 @@ pprConArgs (PrefixCon pats) = interppSP pats
 pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
 pprConArgs (RecCon rpats)   = braces (hsep (punctuate comma (map (pp_rpat) rpats)))
 			    where
-			      pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
-
+			      pp_rpat (HsRecField v p d) = 
+                                hsep [ppr d, ppr v, char '=', ppr p]
 
 -- add parallel array brackets around a document
 --
 pabrackets   :: SDoc -> SDoc
 pabrackets p  = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+
+instance (OutputableBndr id, Outputable arg) =>
+         Outputable (HsRecField id arg) where
+    ppr (HsRecField n ty doc) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
 \end{code}
 
 

compiler/hsSyn/HsSyn.lhs

@@ -17,10 +17,14 @@ module HsSyn (
 	module HsPat,
 	module HsTypes,
  	module HsUtils,
+	module HsDoc,
 	Fixity,
 
-	HsModule(..), HsExtCore(..)
-     ) where
+	HsModule(..), HsExtCore(..),
+
+	HaddockModInfo(..),
+	emptyHaddockModInfo,
+) where
 
 #include "HsVersions.h"
 
@@ -34,6 +38,7 @@ import HsPat
 import HsTypes
 import BasicTypes	( Fixity, DeprecTxt )
 import HsUtils
+import HsDoc
 
 -- others:
 import IfaceSyn		( IfaceBinding )
@@ -57,6 +62,24 @@ data HsModule name
 				-- often empty, downstream.
 	[LHsDecl name]		-- Type, class, value, and interface signature decls
 	(Maybe DeprecTxt)	-- reason/explanation for deprecation of this module
+	(Maybe String)          -- Haddock options, declared with the {-# DOCOPTIONS ... #-} pragma
+	(HaddockModInfo name)   -- Haddock module info
+	(Maybe (HsDoc name))    -- Haddock module description
+
+data HaddockModInfo name = HaddockModInfo { 
+	hmi_description :: Maybe (HsDoc name),
+	hmi_portability :: Maybe String,
+	hmi_stability   :: Maybe String,
+	hmi_maintainer  :: Maybe String
+}
+
+emptyHaddockModInfo :: HaddockModInfo a                                                  
+emptyHaddockModInfo = HaddockModInfo {                                                  
+	hmi_description = Nothing,
+	hmi_portability = Nothing,
+	hmi_stability   = Nothing,
+	hmi_maintainer  = Nothing
+}       
 
 data HsExtCore name	-- Read from Foo.hcr
   = HsExtCore
@@ -66,15 +89,20 @@ data HsExtCore name	-- Read from Foo.hcr
 	[IfaceBinding]	-- And the bindings
 \end{code}
 
+
 \begin{code}
+instance Outputable Char where
+  ppr c = text [c]
+
 instance (OutputableBndr name)
 	=> Outputable (HsModule name) where
 
-    ppr (HsModule Nothing _ imports decls _)
-      = pp_nonnull imports $$ pp_nonnull decls
+    ppr (HsModule Nothing _ imports decls _ _ _ mbDoc)
+      = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls
 
-    ppr (HsModule (Just name) exports imports decls deprec)
+    ppr (HsModule (Just name) exports imports decls deprec opts _ mbDoc)
       = vcat [
+	    pp_mb mbDoc,
 	    case exports of
 	      Nothing -> pp_header (ptext SLIT("where"))