Merge Haddock comment support from ghc.haddock -- big patch
authordavve@dtek.chalmers.se <unknown>
Thu, 5 Oct 2006 22:02:58 +0000 (22:02 +0000)
committerdavve@dtek.chalmers.se <unknown>
Thu, 5 Oct 2006 22:02:58 +0000 (22:02 +0000)
40 files changed:
compiler/cmm/CmmLex.x
compiler/deSugar/Check.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/MatchCon.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsDoc.hs [new file with mode: 0644]
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.lhs
compiler/main/HscStats.lhs
compiler/package.conf.in
compiler/parser/HaddockLex.hs-boot [new file with mode: 0644]
compiler/parser/HaddockLex.x [new file with mode: 0644]
compiler/parser/HaddockParse.y [new file with mode: 0644]
compiler/parser/HaddockUtils.hs [new file with mode: 0644]
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnHsDoc.hs [new file with mode: 0644]
compiler/rename/RnHsSyn.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcTyClsDecls.lhs

index d1a64f6..2bf4ff3 100644 (file)
@@ -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
 
 -- -----------------------------------------------------------------------------
index 85b8f9d..dbf2d72 100644 (file)
@@ -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)]
index 1406d63..b4ecf01 100644 (file)
@@ -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
index fd840e6..c4c38b1 100644 (file)
@@ -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}
index cd5b36d..dff6a14 100644 (file)
@@ -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
index 0588047..8845522 100644 (file)
@@ -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
index 9543cad..733a8ea 100644 (file)
@@ -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}
 
 %************************************************************************
 %*                                                                     *
diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs
new file mode 100644 (file)
index 0000000..51ef579
--- /dev/null
@@ -0,0 +1,77 @@
+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
index f63d86a..767be42 100644 (file)
@@ -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}
index 79b9062..f2ba6b3 100644 (file)
@@ -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}
 
 
index 2169b1a..fb5162a 100644 (file)
@@ -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"))
              Just es -> vcat [
@@ -84,7 +112,7 @@ instance (OutputableBndr name)
                          ],
            pp_nonnull imports,
            pp_nonnull decls
-       ]
+          ]
       where
        pp_header rest = case deprec of
            Nothing -> pp_modname <+> rest
@@ -92,6 +120,9 @@ instance (OutputableBndr name)
 
        pp_modname = ptext SLIT("module") <+> ppr name
 
+pp_mb (Just x) = ppr x 
+pp_mb Nothing  = empty
+
 pp_nonnull [] = empty
 pp_nonnull xs = vcat (map ppr xs)
 \end{code}
index 2693a10..ad7facb 100644 (file)
@@ -34,6 +34,7 @@ import Type           ( Type )
 import {- Kind parts of -} 
        Type            ( {- instance Outputable Kind -} Kind,
                          pprParendKind, pprKind, isLiftedTypeKind )
+import HsDoc            ( LHsDoc, HsDoc )
 import BasicTypes      ( IPName, Boxity, tupleParens )
 import SrcLoc          ( Located(..), unLoc, noSrcSpan )
 import StaticFlags     ( opt_PprStyle_Debug )
@@ -157,6 +158,8 @@ data HsType name
 
   | HsSpliceTy         (HsSplice name)
 
+  | HsDocTy             (LHsType name) (LHsDoc name) -- A documented type
+
 data HsExplicitForAll = Explicit | Implicit
 
 -----------------------
@@ -363,6 +366,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty)
   -- But we still use the precedence stuff to add parens because
   --   toHsType doesn't put in any HsParTys, so we may still need them
 
+ppr_mono_ty ctxt_prec (HsDocTy ty doc)
+  = ppr ty <+> ppr (unLoc doc)
+
 --------------------------
 ppr_fun_ty ctxt_prec ty1 ty2
   = let p1 = ppr_mono_lty pREC_FUN ty1
index da0e24c..5d7132e 100644 (file)
@@ -22,6 +22,7 @@ import HsExpr
 import HsPat
 import HsTypes 
 import HsLit
+import HsDecls
 
 import RdrName         ( RdrName, getRdrName, mkRdrUnqual )
 import Var             ( Id )
@@ -416,3 +417,21 @@ collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConArgs ps)
 collect_pat other              acc = acc       -- Literals, vars, wildcard
 \end{code}
+
+%************************************************************************
+%*                                                                     *
+%*     Getting the main binder name of a top declaration
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+
+getMainDeclBinder :: HsDecl name -> Maybe name
+getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder (ValD d) = Just ((unLoc . head) (collectAcc d []))
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
+getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
+getMainDeclBinder _ = Nothing
+
+\end{code}
index d93e944..9a8804a 100644 (file)
@@ -39,13 +39,14 @@ module DynFlags (
        getVerbFlag,
        updOptLevel,
        setTmpDir,
+       setPackageName,
        
        -- parsing DynFlags
        parseDynamicFlags,
         allFlags,
 
        -- misc stuff
-       machdepCCOpts, picCCOpts,
+       machdepCCOpts, picCCOpts
   ) where
 
 #include "HsVersions.h"
@@ -196,6 +197,7 @@ data DynFlag
    | Opt_StgStats
    | Opt_HideAllPackages
    | Opt_PrintBindResult
+   | Opt_Haddock
 
    -- keeping stuff
    | Opt_KeepHiDiffs
@@ -812,7 +814,6 @@ dynamic_flags = [
   ,  ( "F"             , NoArg  (setDynFlag Opt_Pp))
   ,  ( "#include"      , HasArg (addCmdlineHCInclude) )
   ,  ( "v"             , OptIntSuffix setVerbosity )
-
         ------- Specific phases  --------------------------------------------
   ,  ( "pgmL"           , HasArg (upd . setPgmL) )  
   ,  ( "pgmP"           , HasArg (upd . setPgmP) )  
@@ -873,6 +874,7 @@ dynamic_flags = [
        ------- Miscellaneous ----------------------------------------------
   ,  ( "no-hs-main"     , NoArg (setDynFlag Opt_NoHsMain))
   ,  ( "main-is"       , SepArg setMainIs )
+  ,  ( "haddock"       , NoArg (setDynFlag Opt_Haddock) )
 
        ------- recompilation checker (DEPRECATED, use -fforce-recomp) -----
   ,  ( "recomp"                , NoArg (unSetDynFlag Opt_ForceRecomp) )
@@ -881,7 +883,7 @@ dynamic_flags = [
         ------- Packages ----------------------------------------------------
   ,  ( "package-conf"   , HasArg extraPkgConf_ )
   ,  ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) )
-  ,  ( "package-name"   , HasArg setPackageName )
+  ,  ( "package-name"   , HasArg (upd . setPackageName) )
   ,  ( "package"        , HasArg exposePackage )
   ,  ( "hide-package"   , HasArg hidePackage )
   ,  ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) )
@@ -1095,11 +1097,12 @@ hidePackage p =
   upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
 ignorePackage p = 
   upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
+
 setPackageName p
   | Nothing <- unpackPackageId pid
   = throwDyn (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
   | otherwise
-  = upd (\s -> s{ thisPackage = pid })
+  = \s -> s{ thisPackage = pid }
   where
         pid = stringToPackageId p
 
index 250187a..dab148a 100644 (file)
@@ -40,6 +40,9 @@ module GHC (
        checkModule, CheckedModule(..),
        TypecheckedSource, ParsedSource, RenamedSource,
 
+       -- * Parsing Haddock comments
+       parseHaddockComment,
+
        -- * Inspecting the module structure of the program
        ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
        getModuleGraph,
@@ -191,7 +194,7 @@ import NameSet              ( NameSet, nameSetToList, elemNameSet )
 import RdrName         ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), 
                          globalRdrEnvElts, extendGlobalRdrEnv,
                           emptyGlobalRdrEnv )
-import HsSyn
+import HsSyn 
 import Type            ( Kind, Type, dropForAlls, PredType, ThetaType,
                          pprThetaArrow, pprParendType, splitForAllTys,
                          funResultTy )
@@ -244,6 +247,8 @@ import Outputable
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
 import Maybes          ( expectJust, mapCatMaybes )
+import HaddockParse     ( parseHaddockParagraphs, parseHaddockString )
+import HaddockLex       ( tokenise )
 
 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )
@@ -475,6 +480,12 @@ setGlobalTypeScope session ids
       hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
 
 -- -----------------------------------------------------------------------------
+-- Parsing Haddock comments
+
+parseHaddockComment :: String -> Either String (HsDoc RdrName)
+parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+
+-- -----------------------------------------------------------------------------
 -- Loading the program
 
 -- Perform a dependency analysis starting from the current targets
@@ -762,7 +773,8 @@ data CheckedModule =
        --  fields within CheckedModule.
 
 type ParsedSource      = Located (HsModule RdrName)
-type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
+type RenamedSource     = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+                          Maybe (HsDoc Name), HaddockModInfo Name)
 type TypecheckedSource = LHsBinds Id
 
 -- NOTE:
index 847d193..48eda22 100644 (file)
@@ -66,7 +66,7 @@ getImports dflags buf filename = do
        PFailed span err -> parseError span err
        POk _ rdr_module -> 
          case rdr_module of
-           L _ (HsModule mod _ imps _ _) ->
+           L _ (HsModule mod _ imps _ _ _ _ _) ->
              let
                mod_name | Just located_mod <- mod = located_mod
                         | otherwise               = L noSrcSpan mAIN_NAME
index 55d84b4..bea07c0 100644 (file)
@@ -25,7 +25,8 @@ module HscMain
 #include "HsVersions.h"
 
 #ifdef GHCI
-import HsSyn           ( Stmt(..), LStmt, LHsType )
+import HsSyn           ( Stmt(..), LHsExpr, LStmt, LHsType )
+import Module          ( Module )
 import CodeOutput      ( outputForeignStubs )
 import ByteCodeGen     ( byteCodeGen, coreExprToBCOs )
 import Linker          ( HValue, linkExpr )
@@ -48,7 +49,8 @@ import VarEnv         ( emptyTidyEnv )
 import Var             ( Id )
 import Module          ( emptyModuleEnv, ModLocation(..) )
 import RdrName         ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
-import HsSyn           ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl )
+import HsSyn           ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
+                          HaddockModInfo )
 import SrcLoc          ( Located(..) )
 import StringBuffer    ( hGetStringBuffer, stringToStringBuffer )
 import Parser
@@ -175,7 +177,8 @@ data HscChecked
         -- parsed
         (Located (HsModule RdrName))
         -- renamed
-        (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
+        (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+                Maybe (HsDoc Name), HaddockModInfo Name))
         -- typechecked
         (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
 
@@ -684,7 +687,9 @@ hscFileCheck hsc_env mod_summary = do {
                     rnInfo = do decl <- tcg_rn_decls tc_result
                                 imports <- tcg_rn_imports tc_result
                                 let exports = tcg_rn_exports tc_result
-                                return (decl,imports,exports)
+                               let doc = tcg_doc tc_result
+                                   hmi = tcg_hmi tc_result
+                                return (decl,imports,exports,doc,hmi)
                return (Just (HscChecked rdr_module 
                                    rnInfo
                                   (Just (tcg_binds tc_result,
index 5ceef37..ee8717f 100644 (file)
@@ -23,7 +23,7 @@ import Util             ( count )
 %************************************************************************
 
 \begin{code}
-ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
  = (if short then hcat else vcat)
         (map pp_val
               [("ExportAll        ", export_all), -- 1 if no export list
index b915ce4..383ed85 100644 (file)
@@ -112,6 +112,7 @@ exposed-modules:
        HsSyn
        HsTypes
        HsUtils
+        HsDoc
        HscMain
        HscStats
        HscTypes
@@ -256,6 +257,8 @@ exposed-modules:
        VarSet
        WorkWrap
        WwLib
+       HaddockParse
+       HaddockLex
 
 #ifdef INSTALLING
 import-dirs:   PKG_LIBDIR"/hslibs-imports/ghc"
diff --git a/compiler/parser/HaddockLex.hs-boot b/compiler/parser/HaddockLex.hs-boot
new file mode 100644 (file)
index 0000000..abfc2d6
--- /dev/null
@@ -0,0 +1,18 @@
+module HaddockLex ( Token(..), tokenise ) where
+
+import RdrName
+
+tokenise :: String -> [Token]
+
+data Token
+  = TokPara
+  | TokNumber
+  | TokBullet
+  | TokDefStart
+  | TokDefEnd
+  | TokSpecial Char
+  | TokIdent [RdrName]
+  | TokString String
+  | TokURL String
+  | TokAName String
+  | TokBirdTrack String
diff --git a/compiler/parser/HaddockLex.x b/compiler/parser/HaddockLex.x
new file mode 100644 (file)
index 0000000..e4c2d2d
--- /dev/null
@@ -0,0 +1,161 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+-- This file was modified and integrated into GHC by David Waern 2006
+--
+
+{
+module HaddockLex (
+       Token(..),
+       tokenise
+ ) where
+
+import HsSyn
+import Lexer hiding (Token)
+import Parser ( parseIdentifier )
+import StringBuffer
+import OccName
+import RdrName
+import SrcLoc
+import DynFlags
+import DynFlags
+
+import Char
+import Numeric
+import System.IO.Unsafe
+}
+
+$ws    = $white # \n
+$digit = [0-9]
+$hexdigit = [0-9a-fA-F]
+$special =  [\"\@\/]
+$alphanum = [A-Za-z0-9]
+$ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
+
+:-
+
+-- beginning of a paragraph
+<0,para> {
+ $ws* \n               ;
+ $ws* \>               { begin birdtrack }
+ $ws* [\*\-]           { token TokBullet `andBegin` string }
+ $ws* \[               { token TokDefStart `andBegin` def }
+ $ws* \( $digit+ \)    { token TokNumber `andBegin` string }
+ $ws*                  { begin string }                
+}
+
+-- beginning of a line
+<line> {
+  $ws* \>              { begin birdtrack }
+  $ws* \n              { token TokPara `andBegin` para }
+  -- Here, we really want to be able to say
+  -- $ws* (\n | <eof>)         { token TokPara `andBegin` para}
+  -- because otherwise a trailing line of whitespace will result in 
+  -- a spurious TokString at the end of a docstring.  We don't have <eof>,
+  -- though (NOW I realise what it was for :-).  To get around this, we always
+  -- append \n to the end of a docstring.
+  ()                   { begin string }
+}
+
+<birdtrack> .* \n?     { strtoken TokBirdTrack `andBegin` line }
+
+<string,def> {
+  $special                     { strtoken $ \s -> TokSpecial (head s) }
+  \<.*\>                       { strtoken $ \s -> TokURL (init (tail s)) }
+  \#.*\#                       { strtoken $ \s -> TokAName (init (tail s)) }
+  [\'\`] $ident+ [\'\`]                { ident }
+  \\ .                         { strtoken (TokString . tail) }
+  "&#" $digit+ \;              { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
+  "&#" [xX] $hexdigit+ \;      { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
+  -- allow special characters through if they don't fit one of the previous
+  -- patterns.
+  [\'\`\<\#\&\\]                       { strtoken TokString }
+  [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }
+  [^ $special \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
+}
+
+<def> {
+  \]                           { token TokDefEnd `andBegin` string }
+}
+
+-- ']' doesn't have any special meaning outside of the [...] at the beginning
+-- of a definition paragraph.
+<string> {
+  \]                           { strtoken TokString }
+}
+
+{
+data Token
+  = TokPara
+  | TokNumber
+  | TokBullet
+  | TokDefStart
+  | TokDefEnd
+  | TokSpecial Char
+  | TokIdent [RdrName]
+  | TokString String
+  | TokURL String
+  | TokAName String
+  | TokBirdTrack String
+--  deriving Show
+
+-- -----------------------------------------------------------------------------
+-- Alex support stuff
+
+type StartCode = Int
+type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
+
+type AlexInput = (Char,String)
+
+alexGetChar (_, [])   = Nothing
+alexGetChar (_, c:cs) = Just (c, (c,cs))
+
+alexInputPrevChar (c,_) = c
+
+tokenise :: String -> [Token]
+tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
+  where go inp@(_,str) sc =
+         case alexScan inp sc of
+               AlexEOF -> []
+               AlexError _ -> error "lexical error"
+               AlexSkip  inp' len     -> go inp' sc
+               AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
+
+-- NB. we add a final \n to the string, (see comment in the beginning of line
+-- production above).
+eofHack str = str++"\n"
+
+andBegin  :: Action -> StartCode -> Action
+andBegin act new_sc = \str sc cont -> act str new_sc cont
+
+token :: Token -> Action
+token t = \str sc cont -> t : cont sc
+
+strtoken :: (String -> Token) -> Action
+strtoken t = \str sc cont -> t str : cont sc
+
+begin :: StartCode -> Action
+begin sc = \str _ cont -> cont sc
+
+-- -----------------------------------------------------------------------------
+-- Lex a string as a Haskell identifier
+
+ident :: Action
+ident str sc cont = 
+  case strToHsQNames id of
+       Just names -> TokIdent names : cont sc
+       Nothing -> TokString str : cont sc
+ where id = init (tail str)
+
+strToHsQNames :: String -> Maybe [RdrName]
+strToHsQNames str0 = 
+  let buffer = unsafePerformIO (stringToStringBuffer str0)
+      pstate = mkPState buffer noSrcLoc defaultDynFlags
+      lex = lexer (\t -> return t)
+      result = unP parseIdentifier pstate 
+  in case result of 
+       POk _ name -> Just [unLoc name] 
+       _ -> Nothing
+}
diff --git a/compiler/parser/HaddockParse.y b/compiler/parser/HaddockParse.y
new file mode 100644 (file)
index 0000000..f6c80cb
--- /dev/null
@@ -0,0 +1,98 @@
+{
+module HaddockParse (parseHaddockParagraphs, parseHaddockString) where
+
+import {-# SOURCE #-} HaddockLex
+import HsSyn
+import RdrName
+}
+
+%tokentype { Token }
+
+%token '/'     { TokSpecial '/' }
+       '@'     { TokSpecial '@' }
+       '['     { TokDefStart }
+       ']'     { TokDefEnd }
+       DQUO    { TokSpecial '\"' }
+       URL     { TokURL $$ }
+       ANAME   { TokAName $$ }
+       '-'     { TokBullet }
+       '(n)'   { TokNumber }
+       '>..'   { TokBirdTrack $$ }
+       IDENT   { TokIdent $$ }
+       PARA    { TokPara }
+       STRING  { TokString $$ }
+
+%monad { Either String }
+
+%name parseHaddockParagraphs  doc
+%name parseHaddockString seq
+
+%%
+
+doc    :: { HsDoc RdrName }
+       : apara PARA doc        { docAppend $1 $3 }
+       | PARA doc              { $2 }
+       | apara                 { $1 }
+       | {- empty -}           { DocEmpty }
+
+apara  :: { HsDoc RdrName }
+       : ulpara                { DocUnorderedList [$1] }
+       | olpara                { DocOrderedList [$1] }
+        | defpara               { DocDefList [$1] }
+       | para                  { $1 }
+
+ulpara  :: { HsDoc RdrName }
+       : '-' para              { $2 }
+
+olpara  :: { HsDoc RdrName } 
+       : '(n)' para            { $2 }
+
+defpara :: { (HsDoc RdrName, HsDoc RdrName) }
+       : '[' seq ']' seq       { ($2, $4) }
+
+para    :: { HsDoc RdrName }
+       : seq                   { docParagraph $1 }
+       | codepara              { DocCodeBlock $1 }
+
+codepara :: { HsDoc RdrName }
+       : '>..' codepara        { docAppend (DocString $1) $2 }
+       | '>..'                 { DocString $1 }
+
+seq    :: { HsDoc RdrName }
+       : elem seq              { docAppend $1 $2 }
+       | elem                  { $1 }
+
+elem   :: { HsDoc RdrName }
+       : elem1                 { $1 }
+       | '@' seq1 '@'          { DocMonospaced $2 }
+
+seq1   :: { HsDoc RdrName }
+       : elem1 seq1            { docAppend $1 $2 }
+       | elem1                 { $1 }
+
+elem1  :: { HsDoc RdrName }
+       : STRING                { DocString $1 }
+       | '/' strings '/'       { DocEmphasis (DocString $2) }
+       | URL                   { DocURL $1 }
+       | ANAME                 { DocAName $1 }
+       | IDENT                 { DocIdentifier $1 }
+       | DQUO strings DQUO     { DocModule $2 }
+
+strings  :: { String }
+       : STRING                { $1 }
+       | STRING strings        { $1 ++ $2 }
+
+{
+happyError :: [Token] -> Either String a
+happyError toks = 
+--  Left ("parse error in doc string: "  ++ show (take 3 toks))
+  Left ("parse error in doc string")
+
+-- Either monad (we can't use MonadError because GHC < 5.00 has
+-- an older incompatible version).
+instance Monad (Either String) where
+       return        = Right
+       Left  l >>= _ = Left l
+       Right r >>= k = k r
+       fail msg      = Left msg
+}
diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs
new file mode 100644 (file)
index 0000000..72ea20d
--- /dev/null
@@ -0,0 +1,184 @@
+module HaddockUtils where
+
+import HsSyn
+import HsDoc
+import {-# SOURCE #-} HaddockLex
+import HaddockParse
+import SrcLoc
+import RdrName
+
+import Control.Monad
+import Data.Maybe
+import Data.Char
+import Data.Either
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+-- NB.  The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: String -> Either String (String, HaddockModInfo RdrName)                                
+parseModuleHeader str0 =                                                                        
+   let                                                                                          
+      getKey :: String -> String -> (Maybe String,String)                                       
+      getKey key str = case parseKey key str of                                                 
+         Nothing -> (Nothing,str)                                                               
+         Just (value,rest) -> (Just value,rest)                                                 
+                                                                                                
+      (moduleOpt,str1) = getKey "Module" str0                                                   
+      (descriptionOpt,str2) = getKey "Description" str1                                         
+      (copyrightOpt,str3) = getKey "Copyright" str2                                             
+      (licenseOpt,str4) = getKey "License" str3                                                 
+      (licenceOpt,str5) = getKey "Licence" str4                                                 
+      (maintainerOpt,str6) = getKey "Maintainer" str5                                           
+      (stabilityOpt,str7) = getKey "Stability" str6                                             
+      (portabilityOpt,str8) = getKey "Portability" str7                                         
+                                                                                                
+      description1 :: Either String (Maybe (HsDoc RdrName))                                                 
+      description1 = case descriptionOpt of                                                     
+         Nothing -> Right Nothing                                                               
+         Just description -> case parseHaddockString . tokenise $ description of                       
+
+            Left mess -> Left ("Cannot parse Description: " ++ mess)                            
+            Right doc -> Right (Just doc)                                                       
+   in                                                                                           
+      case description1 of                                                                      
+         Left mess -> Left mess                                                                 
+         Right docOpt -> Right (str8,HaddockModInfo {                                               
+            hmi_description = docOpt,                                                               
+            hmi_portability = portabilityOpt,                                                       
+            hmi_stability = stabilityOpt,                                                           
+            hmi_maintainer = maintainerOpt                                                          
+            })
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":" 
+--    [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- >    rather long
+-- >
+-- >    description
+-- >
+-- > The module comment starts here
+-- 
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+   do
+      let
+         (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+         indentation = spaces0
+      afterKey0 <- extractPrefix key toParse1
+      let
+         afterKey1 = extractLeadingSpaces afterKey0
+      afterColon0 <- case snd afterKey1 of
+         ':':afterColon -> return afterColon
+         _ -> Nothing
+      let
+         (_,afterColon1) = extractLeadingSpaces afterColon0
+
+      return (scanKey True indentation afterColon1)
+   where
+      scanKey :: Bool -> String -> String -> (String,String)
+      scanKey isFirst indentation [] = ([],[])
+      scanKey isFirst indentation str =
+         let
+            (nextLine,rest1) = extractNextLine str
+
+            accept = isFirst || sufficientIndentation || allSpaces
+
+            sufficientIndentation = case extractPrefix indentation nextLine of
+               Just (c:_) | isSpace c -> True
+               _ -> False
+
+            allSpaces = case extractLeadingSpaces nextLine of
+               (_,[]) -> True
+               _ -> False
+         in
+            if accept 
+               then
+                  let
+                     (scanned1,rest2) = scanKey False indentation rest1
+
+                     scanned2 = case scanned1 of 
+                        "" -> if allSpaces then "" else nextLine
+                        _ -> nextLine ++ "\n" ++ scanned1
+                  in
+                     (scanned2,rest2)
+               else
+                  ([],str)
+
+      extractLeadingSpaces :: String -> (String,String)
+      extractLeadingSpaces [] = ([],[])
+      extractLeadingSpaces (s@(c:cs)) 
+         | isSpace c = 
+            let
+               (spaces1,cs1) = extractLeadingSpaces cs
+            in
+               (c:spaces1,cs1)
+         | True = ([],s)
+
+      extractNextLine :: String -> (String,String)
+      extractNextLine [] = ([],[])
+      extractNextLine (c:cs) 
+         | c == '\n' =
+            ([],cs)
+         | True =
+            let
+               (line,rest) = extractNextLine cs
+            in
+               (c:line,rest)
+         
+
+      -- indentation returns characters after last newline.
+      indentation :: String -> String
+      indentation s = fromMaybe s (indentation0 s)
+         where
+            indentation0 :: String -> Maybe String
+            indentation0 [] = Nothing
+            indentation0 (c:cs) =
+               case indentation0 cs of
+                  Nothing -> if c == '\n' then Just cs else Nothing
+                  in0 -> in0
+               
+      -- comparison is case-insensitive.
+      extractPrefix :: String -> String -> Maybe String
+      extractPrefix [] s = Just s
+      extractPrefix s [] = Nothing
+      extractPrefix (c1:cs1) (c2:cs2)
+         | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+         | True = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Adding documentation to record fields (used in parsing).
+
+type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
+
+addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
+addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
+
+addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
+addFieldDocs [] _ = []
+addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
+
+addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
+addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
+
+addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocs [] _ = []
+addConDocs [x] doc = [addConDoc x doc]
+addConDocs (x:xs) doc = x : addConDocs xs doc
+
+addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocFirst [] _ = []
+addConDocFirst (x:xs) doc = addConDoc x doc : xs
index 15745d5..4806a8a 100644 (file)
@@ -44,9 +44,9 @@ import Ctype
 import Util            ( maybePrefixMatch, readRational )
 
 import DATA_BITS
-import Data.Char       ( chr )
+import Data.Char       ( chr, isSpace )
 import Ratio
---import TRACE
+import TRACE
 
 #if __GLASGOW_HASKELL__ >= 605
 import Data.Char       ( GeneralCategory(..), generalCategory, isPrint, isUpper )
@@ -86,6 +86,8 @@ $symchar   = [$symbol \:]
 $nl        = [\n\r]
 $idchar    = [$small $large $digit \']
 
+$docsym    = [\| \^ \* \$]
+
 @varid     = $small $idchar*
 @conid     = $large $idchar*
 
@@ -111,16 +113,48 @@ $white_no_nl+                             ;
 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
 -- (this can happen even though pragmas will normally take precedence due to
 -- longest-match, because pragmas aren't valid in every state, but comments
--- are).
-"{-" / { notFollowedBy '#' }           { nested_comment }
+-- are). We also rule out nested Haddock comments, if the -haddock flag is
+-- set.
+
+"{-" / { isNormalComment } { nested_comment lexToken }
 
 -- Single-line comments are a bit tricky.  Haskell 98 says that two or
 -- more dashes followed by a symbol should be parsed as a varsym, so we
 -- have to exclude those.
--- The regex says: "munch all the characters after the dashes, as long as
--- the first one is not a symbol".
-"--"\-* [^$symbol :] .*                        ;
-"--"\-* / { atEOL }                    ;
+
+-- Since Haddock comments aren't valid in every state, we need to rule them
+-- out here.  
+
+-- The following two rules match comments that begin with two dashes, but
+-- continue with a different character. The rules test that this character
+-- is not a symbol (in which case we'd have a varsym), and that it's not a
+-- space followed by a Haddock comment symbol (docsym) (in which case we'd
+-- have a Haddock comment). The rules then munch the rest of the line.
+
+"-- " ~$docsym .* ;
+"--" [^$symbol : \ ] .* ;
+
+-- Next, match Haddock comments if no -haddock flag
+
+"-- " $docsym .* / { ifExtension (not . haddockEnabled) } ;
+
+-- Now, when we've matched comments that begin with 2 dashes and continue
+-- with a different character, we need to match comments that begin with three
+-- or more dashes (which clearly can't be Haddock comments). We only need to
+-- make sure that the first non-dash character isn't a symbol, and munch the
+-- rest of the line.
+
+"---"\-* [^$symbol :] .* ;
+
+-- Since the previous rules all match dashes followed by at least one
+-- character, we also need to match a whole line filled with just dashes.
+
+"--"\-* / { atEOL } ;
+
+-- We need this rule since none of the other single line comment rules
+-- actually match this case.
+
+"-- " / { atEOL } ;
 
 -- 'bol' state: beginning of a line.  Slurp up all the whitespace (including
 -- blank lines) until we find a non-whitespace character, then do layout
@@ -202,7 +236,10 @@ $white_no_nl+                              ;
   "{-#" $whitechar* (CORE|core)                { token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)    { token ITunpack_prag }
 
-  "{-#"                                { nested_comment }
+  "{-#" $whitechar* (DOCOPTIONS|docoptions)
+  / { ifExtension haddockEnabled }     { lex_string_prag ITdocOptions }
+
+ "{-#"                                 { nested_comment lexToken }
 
   -- ToDo: should only be valid inside a pragma:
   "#-}"                                { token ITclose_prag}
@@ -218,12 +255,19 @@ $white_no_nl+                             ;
 
 <0,option_prags,glaexts> {
        -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ... 
-  "{-#" $whitechar* $idchar+            { nested_comment }
+  "{-#" $whitechar* $idchar+           { nested_comment lexToken }
 }
 
 -- '0' state: ordinary lexemes
 -- 'glaexts' state: glasgow extensions (postfix '#', etc.)
 
+-- Haddock comments
+
+<0,glaexts> {
+  "-- " / $docsym    { multiline_doc_comment }
+  "{-" \ ? / $docsym { nested_doc_comment }
+}
+
 -- "special" symbols
 
 <0,glaexts> {
@@ -479,6 +523,14 @@ data Token
 
   | ITunknown String           -- Used when the lexer can't make sense of it
   | ITeof                      -- end of file token
+
+  -- Documentation annotations
+  | ITdocCommentNext  String     -- something beginning '-- |'
+  | ITdocCommentPrev  String     -- something beginning '-- ^'
+  | ITdocCommentNamed String     -- something beginning '-- $'
+  | ITdocSection      Int String -- a section heading
+  | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
+
 #ifdef DEBUG
   deriving Show -- debugging
 #endif
@@ -643,38 +695,144 @@ notFollowedBy char _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf /= char
 notFollowedBySymbol _ _ _ (AI _ _ buf)
   = atEnd buf || currentChar buf `notElem` "!#$%&*+./<=>?@\\^|-~"
 
+isNormalComment bits _ _ (AI _ _ buf)
+  = (if haddockEnabled bits then False else (followedBySpaceDoc buf))
+    || notFollowedByDocOrPragma
+  where 
+    notFollowedByDocOrPragma = not $ spaceAndP buf
+      (\buf' -> currentChar buf' `elem` "|^*$#")
+
+spaceAndP buf p = p buf || currentChar buf == ' ' && p buf'
+  where buf' = snd (nextChar buf)
+
+followedBySpaceDoc buf = spaceAndP buf followedByDoc
+
+followedByDoc buf = currentChar buf `elem` "|^*$"
+
+haddockDisabledAnd p bits _ _ (AI _ _ buf)
+  = if haddockEnabled bits then False else (p buf)
+
 atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
 
 ifExtension pred bits _ _ _ = pred bits
 
+multiline_doc_comment :: Action
+multiline_doc_comment span buf _len = withLexedDocType (worker "")
+  where
+    worker commentAcc input docType oneLine = case alexGetChar input of
+      Just ('\n', input') 
+        | oneLine -> docCommentEnd input commentAcc docType buf span
+        | otherwise -> case checkIfCommentLine input' of
+          Just input -> worker ('\n':commentAcc) input docType False
+          Nothing -> docCommentEnd input commentAcc docType buf span
+      Just (c, input) -> worker (c:commentAcc) input docType oneLine
+      Nothing -> docCommentEnd input commentAcc docType buf span
+      
+    checkIfCommentLine input = check (dropNonNewlineSpace input)
+      where
+        check input = case alexGetChar input of
+          Just ('-', input) -> case alexGetChar input of
+            Just ('-', input) -> case alexGetChar input of
+              Just (c, _) | c /= '-' -> Just input
+              _ -> Nothing
+            _ -> Nothing
+          _ -> Nothing
+
+        dropNonNewlineSpace input = case alexGetChar input of
+          Just (c, input') 
+            | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
+            | otherwise -> input
+          Nothing -> input
+
 {-
   nested comments require traversing by hand, they can't be parsed
   using regular expressions.
 -}
-nested_comment :: Action
-nested_comment span _str _len = do
+nested_comment :: P (Located Token) -> Action
+nested_comment cont span _str _len = do
   input <- getInput
   go 1 input
-  where go 0 input = do setInput input; lexToken
-       go n input = do
-         case alexGetChar input of
-           Nothing  -> err input
-           Just (c,input) -> do
-             case c of
-               '-' -> do
-                 case alexGetChar input of
-                   Nothing  -> err input
-                   Just ('\125',input) -> go (n-1) input
-                   Just (c,_)          -> go n input
-               '\123' -> do
-                 case alexGetChar input of
-                   Nothing  -> err input
-                   Just ('-',input') -> go (n+1) input'
-                   Just (c,input)    -> go n input
-               c -> go n input
-
-        err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
-
+  where
+    go 0 input = do setInput input; cont
+    go n input = case alexGetChar input of
+      Nothing -> errBrace input span
+      Just ('-',input) -> case alexGetChar input of
+        Nothing  -> errBrace input span
+        Just ('\125',input) -> go (n-1) input
+        Just (c,_)          -> go n input
+      Just ('\123',input) -> case alexGetChar input of
+        Nothing  -> errBrace input span
+        Just ('-',input) -> go (n+1) input
+        Just (c,_)       -> go n input
+      Just (c,input) -> go n input
+
+nested_doc_comment :: Action
+nested_doc_comment span buf _len = withLexedDocType (go "")
+  where
+    go commentAcc input docType _ = case alexGetChar input of
+      Nothing -> errBrace input span
+      Just ('-',input) -> case alexGetChar input of
+        Nothing -> errBrace input span
+        Just ('\125',input@(AI end _ buf2)) ->
+          docCommentEnd input commentAcc docType buf span
+        Just (c,_) -> go ('-':commentAcc) input docType False
+      Just ('\123', input) -> case alexGetChar input of
+        Nothing  -> errBrace input span
+        Just ('-',input) -> do
+          setInput input
+          let cont = do input <- getInput; go commentAcc input docType False
+          nested_comment cont span buf _len
+        Just (c,_) -> go ('\123':commentAcc) input docType False
+      Just (c,input) -> go (c:commentAcc) input docType False
+
+withLexedDocType lexDocComment = do
+  input <- getInput
+  case alexGetChar input of
+    Nothing -> error "Can't happen"
+    Just ('|', input) -> lexDocComment input ITdocCommentNext False
+    Just ('^', input) -> lexDocComment input ITdocCommentPrev False
+    Just ('$', input) -> lexDocComment input ITdocCommentNamed False
+    Just ('*', input) -> lexDocSection 1 input 
+ where 
+    lexDocSection n input = case alexGetChar input of 
+      Just ('*', input) -> lexDocSection (n+1) input
+      Just (c, _) -> lexDocComment input (ITdocSection n) True
+      Nothing -> do setInput input; lexToken -- eof reached, lex it normally
+
+-- docCommentEnd
+-------------------------------------------------------------------------------
+-- This function is quite tricky. We can't just return a new token, we also
+-- need to update the state of the parser. Why? Because the token is longer
+-- than what was lexed by Alex, and the lexToken function doesn't know this, so 
+-- it writes the wrong token length to the parser state. This function is
+-- called afterwards, so it can just update the state. 
+
+-- This is complicated by the fact that Haddock tokens can span multiple lines, 
+-- which is something that the original lexer didn't account for. 
+-- I have added last_line_len in the parser state which represents the length 
+-- of the part of the token that is on the last line. It is now used for layout 
+-- calculation in pushCurrentContext instead of last_len. last_len is, like it 
+-- was before, the full length of the token, and it is now only used for error
+-- messages. /Waern 
+
+docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
+                 SrcSpan -> P (Located Token) 
+docCommentEnd input commentAcc docType buf span = do
+  setInput input
+  let (AI loc last_offs nextBuf) = input
+      comment = reverse commentAcc
+      span' = mkSrcSpan (srcSpanStart span) loc
+      last_len = byteDiff buf nextBuf
+      
+      last_line_len = if (last_offs - last_len < 0) 
+        then last_offs
+        else last_len  
+  
+  span `seq` setLastToken span' last_len last_line_len
+  return (L span' (docType comment))
+errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
 open_brace, close_brace :: Action
 open_brace span _str _len = do 
   ctx <- getContext
@@ -1146,6 +1304,7 @@ getCharOrFail =  do
 data LayoutContext
   = NoLayout
   | Layout !Int
+  deriving Show
 
 data ParseResult a
   = POk PState a
@@ -1162,6 +1321,7 @@ data PState = PState {
                                -- beginning of  the current line.
                                -- \t is equal to 8 spaces.
        last_len   :: !Int,     -- len of previous token
+  last_line_len :: !Int,
         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
        extsBitmap :: !Int,     -- bitmap that determines permitted extensions
        context    :: [LayoutContext],
@@ -1213,8 +1373,12 @@ setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
 getSrcLoc :: P SrcLoc
 getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
 
-setLastToken :: SrcSpan -> Int -> P ()
-setLastToken loc len = P $ \s -> POk s{ last_loc=loc, last_len=len } ()
+setLastToken :: SrcSpan -> Int -> Int -> P ()
+setLastToken loc len line_len = P $ \s -> POk s { 
+  last_loc=loc, 
+  last_len=len,
+  last_line_len=line_len 
+} ()
 
 data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
 
@@ -1316,6 +1480,7 @@ tvBit        = 7  -- Scoped type variables enables 'forall' keyword
 bangPatBit = 8 -- Tells the parser to understand bang-patterns
                -- (doesn't affect the lexer)
 idxTysBit  = 9 -- indexed type families: 'family' keyword and kind sigs
+haddockBit = 10 -- Lex and parse Haddock comments
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
 glaExtsEnabled flags = testBit flags glaExtsBit
@@ -1327,20 +1492,22 @@ ipEnabled      flags = testBit flags ipBit
 tvEnabled      flags = testBit flags tvBit
 bangPatEnabled flags = testBit flags bangPatBit
 idxTysEnabled  flags = testBit flags idxTysBit
+haddockEnabled flags = testBit flags haddockBit
 
 -- PState for parsing options pragmas
 --
 pragState :: StringBuffer -> SrcLoc -> PState
 pragState buf loc  = 
   PState {
-      buffer    = buf,
-      last_loc   = mkSrcSpan loc loc,
-      last_offs  = 0,
-      last_len   = 0,
-      loc        = loc,
-      extsBitmap = 0,
-      context    = [],
-      lex_state  = [bol, option_prags, 0]
+      buffer         = buf,
+      last_loc      = mkSrcSpan loc loc,
+      last_offs     = 0,
+      last_len      = 0,
+      last_line_len = 0,
+      loc           = loc,
+      extsBitmap    = 0,
+      context       = [],
+      lex_state     = [bol, option_prags, 0]
     }
 
 
@@ -1349,14 +1516,15 @@ pragState buf loc  =
 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
 mkPState buf loc flags  = 
   PState {
-      buffer    = buf,
-      last_loc   = mkSrcSpan loc loc,
-      last_offs  = 0,
-      last_len   = 0,
-      loc        = loc,
-      extsBitmap = fromIntegral bitmap,
-      context    = [],
-      lex_state  = [bol, if glaExtsEnabled bitmap then glaexts else 0]
+      buffer         = buf,
+      last_loc      = mkSrcSpan loc loc,
+      last_offs     = 0,
+      last_len      = 0,
+      last_line_len = 0,
+      loc           = loc,
+      extsBitmap    = fromIntegral bitmap,
+      context       = [],
+      lex_state     = [bol, if glaExtsEnabled bitmap then glaexts else 0]
        -- we begin in the layout state if toplev_layout is set
     }
     where
@@ -1369,6 +1537,7 @@ mkPState buf loc flags  =
               .|. tvBit      `setBitIf` dopt Opt_ScopedTypeVariables flags
               .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
               .|. idxTysBit  `setBitIf` dopt Opt_IndexedTypes flags
+              .|. haddockBit `setBitIf` dopt Opt_Haddock     flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
@@ -1391,8 +1560,9 @@ popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
 -- This is only used at the outer level of a module when the 'module'
 -- keyword is missing.
 pushCurrentContext :: P ()
-pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_len=len, context=ctx } ->
-  POk s{context = Layout (offs-len) : ctx} ()
+pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } -> 
+    POk s{context = Layout (offs-len) : ctx} ()
+--trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
 
 getOffside :: P Ordering
 getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
@@ -1438,8 +1608,8 @@ lexError str = do
 
 lexer :: (Located Token -> P a) -> P a
 lexer cont = do
-  tok@(L _ tok__) <- lexToken
-  --trace ("token: " ++ show tok__) $ do
+  tok@(L span tok__) <- lexToken
+--  trace ("token: " ++ show tok__) $ do
   cont tok
 
 lexToken :: P (Located Token)
@@ -1449,7 +1619,7 @@ lexToken = do
   exts <- getExts
   case alexScanUser exts inp sc of
     AlexEOF -> do let span = mkSrcSpan loc1 loc1
-                 setLastToken span 0
+                 setLastToken span 0 0
                  return (L span ITeof)
     AlexError (AI loc2 _ buf) -> do 
        reportLexError loc1 loc2 buf "lexical error"
@@ -1457,11 +1627,11 @@ lexToken = do
        setInput inp2
        lexToken
     AlexToken inp2@(AI end _ buf2) len t -> do
-       setInput inp2
-       let span = mkSrcSpan loc1 end
-       let bytes = byteDiff buf buf2
-       span `seq` setLastToken span bytes
-       t span buf bytes
+    setInput inp2
+    let span = mkSrcSpan loc1 end
+    let bytes = byteDiff buf buf2
+    span `seq` setLastToken span bytes bytes
+    t span buf bytes
 
 reportLexError loc1 loc2 buf str
   | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
index 18565a9..7166e1e 100644 (file)
@@ -36,12 +36,18 @@ import Type         ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
 import BasicTypes      ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
                          Activation(..), defaultInlineSpec )
 import OrdList
+import HaddockParse
+import {-# SOURCE #-} HaddockLex hiding ( Token )
+import HaddockUtils
 
 import FastString
 import Maybes          ( orElse )
 import Monad            ( when )
 import Outputable
 import GLAEXTS
+
+import Data.Char
+import Control.Monad    ( mplus )
 }
 
 {-
@@ -57,7 +63,7 @@ would think the two should never occur in the same context.
   -=chak
 
 -----------------------------------------------------------------------------
-Conflicts: 36 shift/reduce (1.25)
+Conflicts: 38 shift/reduce (1.25)
 
 10 for abiguity in 'if x then y else z + 1'            [State 178]
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
@@ -103,6 +109,10 @@ Conflicts: 36 shift/reduce (1.25)
        This saves explicitly defining a grammar for the rule lhs that
        doesn't include 'forall'.
 
+1 for ambiguity when the source file starts with "-- | doc". We need another
+  token of lookahead to determine if a top declaration or the 'module' keyword
+  follows. Shift parses as if the 'module' keyword follows.   
+
 -- ---------------------------------------------------------------------------
 -- Adding location info
 
@@ -267,7 +277,13 @@ incorrect.
  PRIMINTEGER   { L _ (ITprimint    _) }
  PRIMFLOAT     { L _ (ITprimfloat  _) }
  PRIMDOUBLE    { L _ (ITprimdouble _) }
-                   
+
+ DOCNEXT       { L _ (ITdocCommentNext _) }
+ DOCPREV       { L _ (ITdocCommentPrev _) }
+ DOCNAMED      { L _ (ITdocCommentNamed _) }
+ DOCSECTION    { L _ (ITdocSection _ _) }
+ DOCOPTIONS    { L _ (ITdocOptions _) }
+
 -- Template Haskell 
 '[|'            { L _ ITopenExpQuote  }       
 '[p|'           { L _ ITopenPatQuote  }      
@@ -308,13 +324,22 @@ identifier :: { Located RdrName }
 -- know what they are doing. :-)
 
 module         :: { Located (HsModule RdrName) }
-       : 'module' modid maybemoddeprec maybeexports 'where' body 
-               {% fileSrcSpan >>= \ loc ->
-                  return (L loc (HsModule (Just $2) $4 (fst $6) (snd $6) $3)) }
+       : optdoc 'module' modid maybemoddeprec maybeexports 'where' body 
+               {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) -> 
+                  return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 
+                          opt info doc) )}}
        | missing_module_keyword top close
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing 
-                               (fst $2) (snd $2) Nothing)) }
+                          (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo 
+                          Nothing)) }
+
+optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }                             
+        : moduleheader            { (Nothing, fst $1, snd $1) }
+        | docoptions              { (Just $1, emptyHaddockModInfo, Nothing)} 
+        | docoptions moduleheader { (Just $1, fst $2, snd $2) } 
+        | moduleheader docoptions { (Just $2, fst $1, snd $1) } 
+        | {- empty -}             { (Nothing, emptyHaddockModInfo, Nothing) }  
 
 missing_module_keyword :: { () }
        : {- empty -}                           {% pushCurrentContext }
@@ -339,12 +364,14 @@ cvtopdecls :: { [LHsDecl RdrName] }
 -- Module declaration & imports only
 
 header         :: { Located (HsModule RdrName) }
-       : 'module' modid maybemoddeprec maybeexports 'where' header_body
-               {% fileSrcSpan >>= \ loc ->
-                  return (L loc (HsModule (Just $2) $4 $6 [] $3)) }
+       : optdoc 'module' modid maybemoddeprec maybeexports 'where' header_body
+               {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) -> 
+                  return (L loc (HsModule (Just $3) $5 $7 [] $4 
+                   opt info doc))}}
        | missing_module_keyword importdecls
                {% fileSrcSpan >>= \ loc ->
-                  return (L loc (HsModule Nothing Nothing $2 [] Nothing)) }
+                  return (L loc (HsModule Nothing Nothing $2 [] Nothing 
+                   Nothing emptyHaddockModInfo Nothing)) }
 
 header_body :: { [LImportDecl RdrName] }
        :  '{'            importdecls           { $2 }
@@ -357,15 +384,24 @@ maybeexports :: { Maybe [LIE RdrName] }
        :  '(' exportlist ')'                   { Just $2 }
        |  {- empty -}                          { Nothing }
 
-exportlist  :: { [LIE RdrName] }
-       : ','                                   { [] }
+exportlist :: { [LIE RdrName] }
+       : expdoclist ',' expdoclist             { $1 ++ $3 }
        | exportlist1                           { $1 }
 
 exportlist1 :: { [LIE RdrName] }
-       :  export                               { [$1] }
-       |  export ',' exportlist                { $1 : $3 }
-       |  {- empty -}                          { [] }
-
+        : expdoclist export expdoclist ',' exportlist  { $1 ++ ($2 : $3) ++ $5 }
+       | expdoclist export expdoclist                 { $1 ++ ($2 : $3) }
+       | expdoclist                                   { $1 }
+
+expdoclist :: { [LIE RdrName] }
+        : exp_doc expdoclist                           { $1 : $2 }
+        | {- empty -}                                  { [] }
+
+exp_doc :: { LIE RdrName }                                                   
+        : docsection    { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) }
+        | docnamed      { L1 (IEDocNamed ((fst . unLoc) $1)) } 
+        | docnext       { L1 (IEDoc (unLoc $1)) }       
+                       
    -- No longer allow things like [] and (,,,) to be exported
    -- They are built in syntax, always available
 export         :: { LIE RdrName }
@@ -448,17 +484,16 @@ ops       :: { Located [Located RdrName] }
 -- Top-Level Declarations
 
 topdecls :: { OrdList (LHsDecl RdrName) }
-       : topdecls ';' topdecl          { $1 `appOL` $3 }
-       | topdecls ';'                  { $1 }
-       | topdecl                       { $1 }
+        : topdecls ';' topdecl                 { $1 `appOL` $3 }
+        | topdecls ';'                         { $1 }
+       | topdecl                               { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
        : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
        | ty_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
-       | 'instance' inst_type where
-               { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
-                 in unitOL (L (comb3 $1 $2 $3) 
-                           (InstD (InstDecl $2 binds sigs ats))) }
+         | 'instance' inst_type where
+               { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+                 in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats))) }
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
@@ -476,14 +511,14 @@ topdecl :: { OrdList (LHsDecl RdrName) }
 --
 cl_decl :: { LTyClDecl RdrName }
        : 'class' tycl_hdr fds where
-               {% do { let { (binds, sigs, ats)           = 
+               {% do { let { (binds, sigs, ats, docs)           = 
                                cvBindsAndSigs (unLoc $4)
                            ; (ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms      -- only type vars allowed
                      ; checkKindSigs ats
                      ; return $ L (comb4 $1 $2 $3 $4) 
                                   (mkClassDecl (ctxt, tc, tvs) 
-                                               (unLoc $3) sigs binds ats) } }
+                                               (unLoc $3) sigs binds ats docs) } }
 
 -- Type declarations (toplevel)
 --
@@ -709,7 +744,6 @@ decls       :: { Located (OrdList (LHsDecl RdrName)) }
        | decl                          { $1 }
        | {- empty -}                   { noLoc nilOL }
 
-
 decllist :: { Located (OrdList (LHsDecl RdrName)) }
        : '{'            decls '}'      { LL (unLoc $2) }
        |     vocurly    decls close    { $2 }
@@ -802,8 +836,8 @@ safety :: { Safety }
        | 'threadsafe'                  { PlaySafe  True }
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
-       : STRING var '::' sigtype      { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
-       |        var '::' sigtype      { LL (noLoc nilFS, $1, $3) }
+       : STRING var '::' sigtypedoc     { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
+       |        var '::' sigtypedoc     { LL (noLoc nilFS, $1, $3) }
          -- if the entity string is missing, it defaults to the empty string;
          -- the meaning of an empty entity string depends on the calling
          -- convention
@@ -827,6 +861,10 @@ sigtype :: { LHsType RdrName }
        : ctype                         { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
        -- Wrap an Implicit forall if there isn't one there already
 
+sigtypedoc :: { LHsType RdrName }
+       : ctypedoc                      { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
+       -- Wrap an Implicit forall if there isn't one there already
+
 sig_vars :: { Located [Located RdrName] }
         : sig_vars ',' var             { LL ($3 : unLoc $1) }
         | var                          { L1 [$1] }
@@ -834,6 +872,27 @@ sig_vars :: { Located [Located RdrName] }
 -----------------------------------------------------------------------------
 -- Types
 
+infixtype :: { LHsType RdrName }
+       : btype qtyconop gentype         { LL $ HsOpTy $1 $2 $3 }
+        | btype tyvarop  gentype        { LL $ HsOpTy $1 $2 $3 }
+
+infixtypedoc :: { LHsType RdrName }
+        : infixtype                      { $1 }
+       | infixtype docprev              { LL $ HsDocTy $1 $2 }
+
+gentypedoc :: { LHsType RdrName }
+        : btype                          { $1 }
+        | btypedoc                       { $1 }
+        | infixtypedoc                   { $1 }
+        | btype '->' ctypedoc            { LL $ HsFunTy $1 $3 }
+        | btypedoc '->' ctypedoc         { LL $ HsFunTy $1 $3 }
+
+ctypedoc  :: { LHsType RdrName }
+        : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
+        | context '=>' gentypedoc        { LL $ mkImplicitHsForAllTy   $1 $3 }
+       -- A type of form (context => type) is an *implicit* HsForAllTy
+       | gentypedoc                     { $1 }
+       
 strict_mark :: { Located HsBang }
        : '!'                           { L1 HsStrict }
        | '{-# UNPACK' '#-}' '!'        { LL HsUnbox }
@@ -866,6 +925,10 @@ btype :: { LHsType RdrName }
        : btype atype                   { LL $ HsAppTy $1 $2 }
        | atype                         { $1 }
 
+btypedoc :: { LHsType RdrName }
+       : btype atype docprev           { LL $ HsDocTy (L (comb2 $1 $2) (HsAppTy $1 $2)) $3 }
+        | atype docprev                 { LL $ HsDocTy $1 $2 }
+
 atype :: { LHsType RdrName }
        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
        | tyvar                         { L1 (HsTyVar (unLoc $1)) }
@@ -962,32 +1025,32 @@ gadt_constr :: { LConDecl RdrName }
         -- XXX revisit audreyt
        | constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $1 in 
-                 LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) }
+                 LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing) }
 {-
        | forall context '=>' constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $4 in 
-                 LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6)) }
+                 LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6) Nothing ) }
        | forall constr_stuff_record '::' sigtype
                { let (con,details) = unLoc $2 in 
-                 LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4)) }
+                 LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4) Nothing) }
 -}
 
 
 constrs :: { Located [LConDecl RdrName] }
         : {- empty; a GHC extension -}  { noLoc [] }
-        | '=' constrs1                  { LL (unLoc $2) }
+        | maybe_docnext '=' constrs1    { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
 
 constrs1 :: { Located [LConDecl RdrName] }
-       : constrs1 '|' constr           { LL ($3 : unLoc $1) }
-       | constr                        { L1 [$1] }
+       : constrs1 maybe_docnext '|' maybe_docprev constr { LL (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) }
+       | constr                                          { L1 [$1] }
 
 constr :: { LConDecl RdrName }
-       : forall context '=>' constr_stuff      
-               { let (con,details) = unLoc $4 in 
-                 LL (ConDecl con Explicit (unLoc $1) $2 details ResTyH98) }
-       | forall constr_stuff
-               { let (con,details) = unLoc $2 in 
-                 LL (ConDecl con Explicit (unLoc $1) (noLoc []) details ResTyH98) }
+       : maybe_docnext forall context '=>' constr_stuff maybe_docprev  
+               { let (con,details) = unLoc $5 in 
+                 L (comb4 $2 $3 $4 $5) (ConDecl con Explicit (unLoc $2) $3 details ResTyH98 ($1 `mplus` $6)) }
+       | maybe_docnext forall constr_stuff maybe_docprev
+               { let (con,details) = unLoc $3 in 
+                 L (comb2 $2 $3) (ConDecl con Explicit (unLoc $2) (noLoc []) details ResTyH98 ($1 `mplus` $4)) }
 
 forall :: { Located [LHsTyVarBndr RdrName] }
        : 'forall' tv_bndrs '.'         { LL $2 }
@@ -1010,12 +1073,12 @@ constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangTy
        : oqtycon '{' '}'               {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
        | oqtycon '{' fielddecls '}'    {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
 
-fielddecls :: { [([Located RdrName], LBangType RdrName)] }
-       : fielddecl ',' fielddecls      { unLoc $1 : $3 }
-       | fielddecl                     { [unLoc $1] }
+fielddecls :: { [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] }
+       : fielddecl maybe_docnext ',' maybe_docprev fielddecls { addFieldDoc (unLoc $1) $4 : addFieldDocs $5 $2 }
+       | fielddecl                                            { [unLoc $1] }
 
-fielddecl :: { Located ([Located RdrName], LBangType RdrName) }
-       : sig_vars '::' ctype           { LL (reverse (unLoc $1), $3) }
+fielddecl :: { Located ([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName)) }
+       : maybe_docnext sig_vars '::' ctype maybe_docprev      { L (comb3 $2 $3 $4) (reverse (unLoc $2), $4, $1 `mplus` $5) }
 
 -- We allow the odd-looking 'inst_type' in a deriving clause, so that
 -- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
@@ -1054,14 +1117,24 @@ deriving :: { Located (Maybe [LHsType RdrName]) }
   We can't tell whether to reduce var to qvar until after we've read the signatures.
 -}
 
+docdecl :: { LHsDecl RdrName }
+        : docdecld { L1 (DocD (unLoc $1)) }
+
+docdecld :: { LDocDecl RdrName }
+        : docnext                               { L1 (DocCommentNext (unLoc $1)) }
+        | docprev                               { L1 (DocCommentPrev (unLoc $1)) }
+        | docnamed                              { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
+        | docsection                            { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }
+
 decl   :: { Located (OrdList (LHsDecl RdrName)) }
        : sigdecl                       { $1 }
        | '!' infixexp rhs              {% do { pat <- checkPattern $2;
-                                               return (LL $ unitOL $ LL $ ValD $ 
+                                               return (LL $ unitOL $ LL $ ValD ( 
                                                        PatBind (LL $ BangPat pat) (unLoc $3)
-                                                               placeHolderType placeHolderNames) } }
+                                                               placeHolderType placeHolderNames)) } }
        | infixexp opt_sig rhs          {% do { r <- checkValDef $1 $2 $3;
                                                return (LL $ unitOL (LL $ ValD r)) } }
+        | docdecl                       { LL $ unitOL $1 }
 
 rhs    :: { Located (GRHSs RdrName) }
        : '=' exp wherebinds    { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
@@ -1075,18 +1148,18 @@ gdrh :: { LGRHS RdrName }
        : '|' quals '=' exp     { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
-       : infixexp '::' sigtype
+       : infixexp '::' sigtypedoc
                                {% do s <- checkValSig $1 $3; 
                                      return (LL $ unitOL (LL $ SigD s)) }
                -- See the above notes for why we need infixexp here
-       | var ',' sig_vars '::' sigtype 
+       | var ',' sig_vars '::' sigtypedoc
                                { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                             | n <- unLoc $3 ] }
        | '{-# INLINE'   activation qvar '#-}'        
                                { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
-                               { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
+                               { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) 
                                            | t <- $4] }
        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
                                { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
@@ -1645,6 +1718,53 @@ commas :: { Int }
        | ','                           { 2 }
 
 -----------------------------------------------------------------------------
+-- Documentation comments
+
+docnext :: { LHsDoc RdrName }
+  : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
+      Left  err -> parseError (getLoc $1) err;
+      Right doc -> return (L1 doc) } }
+
+docprev :: { LHsDoc RdrName }
+  : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
+      Left  err -> parseError (getLoc $1) err;
+      Right doc -> return (L1 doc) } }
+
+docnamed :: { Located (String, (HsDoc RdrName)) }
+  : DOCNAMED {%
+      let string = getDOCNAMED $1 
+          (name, rest) = break isSpace string
+      in case parseHaddockParagraphs (tokenise rest) of {
+        Left  err -> parseError (getLoc $1) err;
+        Right doc -> return (L1 (name, doc)) } }
+
+docsection :: { Located (n, HsDoc RdrName) }
+  : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
+        case parseHaddockString (tokenise doc) of {
+      Left  err -> parseError (getLoc $1) err;
+      Right doc -> return (L1 (n, doc)) } }
+
+docoptions :: { String }
+  : DOCOPTIONS { getDOCOPTIONS $1 }
+
+moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }                                    
+        : DOCNEXT {% let string = getDOCNEXT $1 in
+               case parseModuleHeader string of {                       
+                 Right (str, info) ->                                  
+                   case parseHaddockParagraphs (tokenise str) of {               
+                     Left err -> parseError (getLoc $1) err;                    
+                     Right doc -> return (info, Just doc);          
+                   };                                             
+                 Left err -> parseError (getLoc $1) err                           
+            }  }                                                  
+
+maybe_docprev :: { Maybe (LHsDoc RdrName) }
+       : docprev                       { Just $1 }
+       | {- empty -}                   { Nothing }
+
+maybe_docnext :: { Maybe (LHsDoc RdrName) }
+       : docnext                       { Just $1 }
+       | {- empty -}                   { Nothing }
 
 {
 happyError :: P a
@@ -1672,6 +1792,12 @@ getTH_ID_SPLICE (L _ (ITidEscape x)) = x
 getINLINE      (L _ (ITinline_prag b)) = b
 getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
 
+getDOCNEXT (L _ (ITdocCommentNext x)) = x
+getDOCPREV (L _ (ITdocCommentPrev x)) = x
+getDOCNAMED (L _ (ITdocCommentNamed x)) = x
+getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
+getDOCOPTIONS (L _ (ITdocOptions x)) = x
+
 -- Utilities for combining source spans
 comb2 :: Located a -> Located b -> SrcSpan
 comb2 = combineLocs
index a6ee5dd..dd3d8b7 100644 (file)
@@ -108,7 +108,7 @@ trep    :: { OccName -> [LConDecl RdrName] }
         | '=' ty        { (\ tc_occ -> let { dc_name  = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
                                             con_info = PrefixCon [toHsType $2] }
                                        in [noLoc $ ConDecl (noLoc dc_name) Explicit []
-                                          (noLoc []) con_info ResTyH98]) }
+                                          (noLoc []) con_info ResTyH98 Nothing]) }
 
 cons   :: { [LConDecl RdrName] }
        : {- empty -}   { [] } -- 20060420 Empty data types allowed. jds
@@ -116,7 +116,7 @@ cons        :: { [LConDecl RdrName] }
 
 con    :: { LConDecl RdrName }
        : d_pat_occ attv_bndrs hs_atys 
-               { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
+               { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
         | d_pat_occ '::' ty
                 -- XXX - audreyt - $3 needs to be split into argument and return types!
                 -- also not sure whether the [] below (quantified vars) appears.
@@ -124,7 +124,7 @@ con :: { LConDecl RdrName }
                 -- also we want to munge $3 somehow.
                 -- extractWhatEver to unpack ty into the parts to ConDecl
                 -- XXX - define it somewhere in RdrHsSyn
-               { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
+               { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) Nothing }
 
 attv_bndrs :: { [LHsTyVarBndr RdrName] }
        : {- empty -}            { [] }
index 87741b9..8e4570a 100644 (file)
@@ -15,7 +15,7 @@ module RdrHsSyn (
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
 
        cvBindGroup,
-       cvBindsAndSigs,
+        cvBindsAndSigs,
        cvTopDecls,
        findSplice, mkGroup,
 
@@ -119,6 +119,7 @@ extract_lty (L loc ty) acc
                                           extract_lctxt cx (extract_lty ty []))
                                where
                                   locals = hsLTyVarNames tvs
+      HsDocTy ty doc            -> extract_lty ty acc 
 
 extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
 extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
@@ -155,12 +156,13 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
        *** See "THE NAMING STORY" in HsDecls ****
   
 \begin{code}
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,
                tcdMeths = mbinds,
-               tcdATs   = ats
+               tcdATs   = ats,
+               tcdDocs  = docs
                }
 
 mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
@@ -203,29 +205,30 @@ cvTopDecls decls = go (fromOL decls)
                            where (L l' b', ds') = getMonoBind (L l b) ds
     go (d : ds)            = d : go ds
 
--- Declaration list may only contain value bindings and signatures
---
+-- Declaration list may only contain value bindings and signatures.
 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding
   = case cvBindsAndSigs binding of
-      (mbs, sigs, []) ->                 -- list of type decls *always* empty
+      (mbs, sigs, [], _) ->                 -- list of type decls *always* empty
         ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
--- associated type declarations
+-- associated type declarations. They might also contain Haddock comments.
 cvBindsAndSigs  fb = go (fromOL fb)
   where
-    go []                 = (emptyBag, [], [])
-    go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
-                           where (bs, ss, ts) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+    go []                 = (emptyBag, [], [], [])
+    go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
+                           where (bs, ss, ts, docs) = go ds
+    go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
                            where (b', ds')    = getMonoBind (L l b) ds
-                                 (bs, ss, ts) = go ds'
-    go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
-                           where (bs, ss, ts) = go ds
+                                 (bs, ss, ts, docs) = go ds'
+    go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
+                           where (bs, ss, ts, docs) = go ds
+    go (L _ (DocD d) : ds)     =  (bs, ss, ts, DocEntity d : docs)
+                           where (bs, ss, ts, docs) = go ds
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
@@ -240,21 +243,28 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
 -- belong with b into a single MonoBinds, and ds' is the depleted
 -- list of parsed bindings.
 --
+-- All Haddock comments between equations inside the group are 
+-- discarded.
+--
 -- No AndMonoBinds or EmptyMonoBinds here; just single equations
 
 getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, 
                                   fun_matches = MatchGroup mtchs1 _ })) binds
   | has_args mtchs1
-  = go is_infix1 mtchs1 loc1 binds
+  = go is_infix1 mtchs1 loc1 binds []
   where
     go is_infix mtchs loc 
        (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
-                               fun_matches = MatchGroup mtchs2 _ })) : binds)
+                               fun_matches = MatchGroup mtchs2 _ })) : binds) _
        | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs) 
-                       (combineSrcSpans loc loc2) binds
-    go is_infix mtchs loc binds
-       = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
+                       (combineSrcSpans loc loc2) binds []
+    go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls 
+       = let doc_decls' = doc_decl : doc_decls  
+          in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
+    go is_infix mtchs loc binds doc_decls
+       = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
        -- Reverse the final matches, to get it back in the right order
+        -- Do the same thing with the trailing doc comments
 
 getMonoBind bind binds = (bind, binds)
 
@@ -292,22 +302,26 @@ add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
 add gp l (SpliceD e) ds = (gp, Just (e, ds))
 
 -- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs}) 
+    l decl@(TyClD d) ds
        | isClassDecl d =       
                let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
-               addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
+               addl (gp { hs_tyclds = L l d : ts, 
+                           hs_fixds = fsigs ++ fs,
+                           hs_docs = add_doc decl docs}) ds
        | otherwise =
-               addl (gp { hs_tyclds = L l d : ts }) ds
+               addl (gp { hs_tyclds = L l d : ts, 
+                           hs_docs = add_doc decl docs }) ds
 
 -- Signatures: fixity sigs go a different place than all others
 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
   = addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
-  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
+add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
+  = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
 
 -- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
-  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
+add gp@(HsGroup {hs_valds  = ts, hs_docs = docs}) l x@(ValD d) ds
+  = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
 
 -- The rest are routine
 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
@@ -316,13 +330,20 @@ add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
   = addl (gp { hs_derivds = L l d : ts }) ds
 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
   = addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
-  = addl (gp { hs_fords = L l d : ts }) ds
+add gp@(HsGroup {hs_fords  = ts, hs_docs = docs}) l x@(ForD d) ds
+  = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
 add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
   = addl (gp { hs_depds = L l d : ts }) ds
 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
   = addl (gp { hs_ruleds = L l d : ts }) ds
 
+add gp l (DocD d) ds
+  = addl (gp { hs_docs = DocEntity d : (hs_docs gp) })  ds
+
+add_doc decl docs = case getMainDeclBinder decl of 
+  Just name -> DeclEntity name : docs
+  Nothing   -> docs
 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs                      (s:sigs) 
 \end{code}
@@ -353,11 +374,12 @@ mkPrefixCon ty tys
                                     return (data_con, PrefixCon ts)
    split (L l _) _             = parseError l "parse error in data/newtype declaration"
 
-mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
-  -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+mkRecCon :: Located RdrName -> 
+            [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
+            P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
 mkRecCon (L loc con) fields
   = do data_con <- tyConToDataCon loc con
-       return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
+       return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
 
 tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
 tyConToDataCon loc tc
@@ -682,7 +704,7 @@ checkAPat loc e = case e of
                         return (TuplePat ps b placeHolderType)
    
    RecordCon c _ fs   -> mapM checkPatField fs >>= \fs ->
-                        return (ConPatIn c (RecCon fs))
+                        return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) 
 -- Generics 
    HsType ty          -> return (TypePat ty) 
    _                  -> patFail loc
@@ -761,7 +783,8 @@ mk_gadt_con name qvars cxt ty
            , con_qvars    = qvars
            , con_cxt      = cxt
            , con_details  = PrefixCon []
-           , con_res      = ResTyGADT ty }
+           , con_res      = ResTyGADT ty
+            , con_doc      = Nothing }
   -- NB: we put the whole constr type into the ResTyGADT for now; 
   -- the renamer will unravel it once it has sorted out
   -- operator fixities
index b21c42d..29a8791 100644 (file)
@@ -14,6 +14,7 @@ module RnEnv (
        lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, 
        lookupLocatedInstDeclBndr,
        lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
+       lookupGreRn,    
 
        newLocalsRn, newIPNameRn,
        bindLocalNames, bindLocalNamesFV,
diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs
new file mode 100644 (file)
index 0000000..6941da5
--- /dev/null
@@ -0,0 +1,88 @@
+module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc, rnMbHsDoc ) where
+
+import TcRnMonad   ( RnM )
+import RnEnv       ( dataTcOccs, lookupGreRn )
+import HsDoc       ( HsDoc(..) )
+
+import RdrName     ( RdrName, isRdrDataCon, isRdrTc, gre_name )
+import Name        ( Name )
+import SrcLoc      ( Located(..) )
+import Outputable  ( ppr, defaultUserStyle )
+
+import Data.List   ( (\\) )
+import Debug.Trace ( trace )
+
+rnMbHsDoc mb_doc = case mb_doc of
+  Just doc -> do
+    doc' <- rnHsDoc doc
+    return (Just doc')
+  Nothing -> return Nothing
+
+rnMbLHsDoc mb_doc = case mb_doc of
+  Just doc -> do
+    doc' <- rnLHsDoc doc
+    return (Just doc')
+  Nothing -> return Nothing
+
+rnLHsDoc (L pos doc) = do
+  doc' <- rnHsDoc doc
+  return (L pos doc')
+
+ids2string []    = []
+ids2string (x:_) = show $ ppr x defaultUserStyle
+
+rnHsDoc :: HsDoc RdrName -> RnM (HsDoc Name)
+rnHsDoc doc = case doc of 
+  
+  DocEmpty -> return DocEmpty
+
+  DocAppend a b -> do
+    a' <- rnHsDoc a 
+    b' <- rnHsDoc b
+    return (DocAppend a' b')
+
+  DocString str -> return (DocString str)
+
+  DocParagraph doc -> do
+    doc' <- rnHsDoc doc
+    return (DocParagraph doc')
+
+  DocIdentifier ids -> do
+    let choices = concatMap dataTcOccs ids
+    mb_gres <- mapM lookupGreRn choices 
+    case [gre_name gre | Just gre <- mb_gres] of
+      [] -> return (DocString (ids2string ids))
+      ids' -> return (DocIdentifier ids')
+
+  DocModule str -> return (DocModule str)
+
+  DocEmphasis doc -> do
+    doc' <- rnHsDoc doc
+    return (DocEmphasis doc')
+
+  DocMonospaced doc -> do
+    doc' <- rnHsDoc doc 
+    return (DocMonospaced doc')
+  DocUnorderedList docs -> do
+    docs' <- mapM rnHsDoc docs
+    return (DocUnorderedList docs')
+
+  DocOrderedList docs -> do
+    docs' <- mapM rnHsDoc docs
+    return (DocOrderedList docs')
+
+  DocDefList list -> do
+    list' <- mapM (\(a,b) -> do
+      a' <- rnHsDoc a
+      b' <- rnHsDoc b
+      return (a', b')) list
+    return (DocDefList list')
+
+  DocCodeBlock doc -> do
+    doc' <- rnHsDoc doc
+    return (DocCodeBlock doc')
+
+  DocURL str -> return (DocURL str)
+
+  DocAName str -> return (DocAName str)
index 6752218..53f04e2 100644 (file)
@@ -74,6 +74,7 @@ extractHsTyNames ty
                                         `unionNameSets` getl ty)
                                            `minusNameSet`
                                  mkNameSet (hsLTyVarNames tvs)
+    get (HsDocTy ty _)         = getl ty
 
 extractHsTyNames_s  :: [LHsType Name] -> NameSet
 extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
@@ -129,7 +130,7 @@ conResTyFVs (ResTyGADT ty) = extractHsTyNames ty
 
 conDetailsFVs (PrefixCon btys)     = plusFVs (map bangTyFVs btys)
 conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
-conDetailsFVs (RecCon flds)       = plusFVs [bangTyFVs bty | (_, bty) <- flds]
+conDetailsFVs (RecCon flds)       = plusFVs [bangTyFVs bty | (HsRecField _ bty  _) <- flds]
 
 bangTyFVs bty = extractHsTyNames (getBangType bty)
 \end{code}
index 71890db..a6b021d 100644 (file)
@@ -20,6 +20,7 @@ import HsSyn          ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          instDeclATs, isIdxTyDecl,
                          LIE )
 import RnEnv
+import RnHsDoc          ( rnHsDoc )
 import IfaceEnv                ( ifaceExportNames )
 import LoadIface       ( loadSrcInterface )
 import TcRnMonad hiding (LIE)
@@ -547,7 +548,12 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_names
             ; succeed_with True (name:names) }
     get_item (IEVar name)
         = succeed_with True [name]
-
+    get_item (IEGroup _ _)
+        = succeed_with False []
+    get_item (IEDoc _)
+        = succeed_with False []
+    get_item (IEDocNamed _)
+        = succeed_with False []
 \end{code}
 
 
@@ -619,9 +625,25 @@ rnExports (Just exports)
                              return (IEThingWith name names)
           rnExport (IEModuleContents mod)
               = return (IEModuleContents mod)
+          rnExport (IEGroup lev doc) 
+              = do rn_doc <- rnHsDoc doc
+                   return (IEGroup lev rn_doc)
+          rnExport (IEDoc doc)
+              = do rn_doc <- rnHsDoc doc
+                   return (IEDoc rn_doc)
+          rnExport (IEDocNamed str)
+              = return (IEDocNamed str)
+
        rn_exports <- mapM (wrapLocM rnExport) exports
        return (Just rn_exports)
 
+filterOutDocs = filter notDoc
+       where
+        notDoc (L _ (IEGroup _ _))  = False
+        notDoc (L _ (IEDoc _))      = False
+        notDoc (L _ (IEDocNamed _)) = False 
+        notDoc _                    = True
+
 mkExportNameSet :: Bool  -- False => no 'module M(..) where' header at all
                 -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list
                 -> RnM NameSet
@@ -650,7 +672,11 @@ mkExportNameSet explicit_mod exports
                                      return (Just ([noLoc (IEVar mainName)]
                                                   ,[noLoc (IEVar main_RDR_Unqual)]))
                -- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope
-      exports_from_avail real_exports rdr_env imports
+
+      -- we don't want to include Haddock comments
+      let real_exports' = fmap (\(a,b) -> (filterOutDocs a, filterOutDocs b)) real_exports 
+
+      exports_from_avail real_exports' rdr_env imports
 
 
 exports_from_avail Nothing rdr_env imports
index 9a3e805..670cfc8 100644 (file)
@@ -23,11 +23,12 @@ import RnTypes              ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
 import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
 import RnEnv           ( lookupLocalDataTcNames,
                          lookupLocatedTopBndrRn, lookupLocatedOccRn,
-                         lookupOccRn, newLocalsRn, 
+                         lookupOccRn, lookupTopBndrRn, newLocalsRn, 
                          bindLocatedLocalsFV, bindPatSigTyVarsFV,
                          bindTyVarsRn, extendTyVarEnvFVRn,
                          bindLocalNames, checkDupNames, mapFvRn
                        )
+import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcRnMonad
 
 import HscTypes                ( FixityEnv, FixItem(..),
@@ -73,7 +74,8 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
                      hs_depds  = deprec_decls,
                      hs_fords  = foreign_decls,
                      hs_defds  = default_decls,
-                     hs_ruleds = rule_decls })
+                     hs_ruleds = rule_decls,
+                      hs_docs   = docs })
 
  = do {                -- Deal with deprecations (returns only the extra deprecations)
        deprecs <- rnSrcDeprecDecls deprec_decls ;
@@ -111,7 +113,9 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
           <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
        (rn_default_decls, src_fvs5)
           <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-       
+
+       rn_docs <- mapM rnDocEntity docs ;
+
        let {
           rn_group = HsGroup { hs_valds  = rn_val_decls,
                                hs_tyclds = rn_tycl_decls,
@@ -121,7 +125,8 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
                                hs_depds  = [],
                                hs_fords  = rn_foreign_decls,
                                hs_defds  = rn_default_decls,
-                               hs_ruleds = rn_rule_decls } ;
+                               hs_ruleds = rn_rule_decls,
+                                hs_docs   = rn_docs } ;
 
           other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, 
                                src_fvs4, src_fvs5] ;
@@ -138,6 +143,28 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
        return (tcg_env `addTcgDUs` src_dus, rn_group)
     }}}
 
+rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name)
+rnDocEntity (DocEntity docdecl) = do
+  rn_docdecl <- rnDocDecl docdecl
+  return (DocEntity rn_docdecl)
+rnDocEntity (DeclEntity name) = do
+  rn_name <- lookupTopBndrRn name
+  return (DeclEntity rn_name)
+
+rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl (DocCommentNext doc) = do 
+  rn_doc <- rnHsDoc doc
+  return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do 
+  rn_doc <- rnHsDoc doc
+  return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocGroup lev rn_doc)
+
 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 rnTyClDecls tycl_decls = do 
   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
@@ -611,7 +638,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 
 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
                       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
-                      tcdMeths = mbinds, tcdATs = ats})
+                      tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
   = lookupLocatedTopBndrRn cname               `thenM` \ cname' ->
 
        -- Tyvars scope over superclass context and method signatures
@@ -620,8 +647,9 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
        rnFds cls_doc fds               `thenM` \ fds' ->
        rnATs ats                       `thenM` \ (ats', ats_fvs) ->
        renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
-       returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
-    )  `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
+        mapM rnDocEntity docs           `thenM` \ docs' ->
+       returnM   (tyvars', context', fds', (ats', ats_fvs), sigs', docs')
+    )  `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs', docs') ->
 
        -- Check for duplicates among the associated types
     let
@@ -663,7 +691,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 
     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', 
                         tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
-                        tcdMeths = mbinds', tcdATs = ats'},
+                        tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
             delFVs (map hsLTyVarName tyvars')  $
             extractHsCtxtTyNames context'          `plusFV`
             plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
@@ -701,7 +729,7 @@ rnConDecls tycon condecls
   = mappM (wrapLocM rnConDecl) condecls
 
 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name expl tvs cxt details res_ty)
+rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
   = do { addLocM checkConName name
 
        ; new_name <- lookupLocatedTopBndrRn name
@@ -720,12 +748,14 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty)
                        Explicit -> tvs
                        Implicit -> userHsTyVarBndrs implicit_tvs
 
+       ; mb_doc' <- rnMbLHsDoc mb_doc 
+
        ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
        { new_context <- rnContext doc cxt
         ; new_details <- rnConDetails doc details
         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
-        ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
 where
+        ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
+ where
     doc = text "In the definition of data constructor" <+> quotes (ppr name)
     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 
@@ -754,12 +784,14 @@ rnConDetails doc (RecCon fields)
     mappM (rnField doc) fields         `thenM` \ new_fields ->
     returnM (RecCon new_fields)
   where
-    field_names = [fld | (fld, _) <- fields]
+    field_names = [ name | HsRecField name _ _ <- fields ]
 
-rnField doc (name, ty)
+-- Document comments are renamed to Nothing here
+rnField doc (HsRecField name ty haddock_doc)
   = lookupLocatedTopBndrRn name        `thenM` \ new_name ->
     rnLHsType doc ty           `thenM` \ new_ty ->
-    returnM (new_name, new_ty) 
+    rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
+    returnM (HsRecField new_name new_ty new_haddock_doc) 
 
 -- Rename kind signatures (signatures of indexed data types/newtypes and
 -- signatures of type functions)
index 0aa0b4e..fe51c1a 100644 (file)
@@ -28,6 +28,7 @@ import RdrHsSyn               ( extractHsRhoRdrTyVars )
 import RnHsSyn         ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
                          listTyCon_name
                        )
+import RnHsDoc          ( rnLHsDoc )
 import RnEnv           ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
                          lookupLocatedOccRn, lookupLocatedBndrRn,
                          lookupLocatedGlobalOccRn, bindTyVarsRn, 
@@ -188,6 +189,11 @@ rnHsType doc (HsSpliceTy _)
   = do { addErr (ptext SLIT("Type splices are not yet implemented"))
        ; failM }
 
+rnHsType doc (HsDocTy ty haddock_doc)
+  = rnLHsType doc ty           `thenM` \ ty' ->
+    rnLHsDoc haddock_doc       `thenM` \ haddock_doc' ->
+    returnM (HsDocTy ty' haddock_doc')
+
 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
 \end{code}
 
@@ -667,21 +673,22 @@ rnConPat con (InfixCon pat1 pat2)
 -- -----------------------------------------------------------------------------
 -- rnRpats
 
-rnRpats :: [(Located RdrName, LPat RdrName)]
-        -> RnM ([(Located Name, LPat Name)], FreeVars)
+-- Haddock comments for record fields are renamed to Nothing here
+rnRpats :: [HsRecField RdrName (LPat RdrName)] 
+        -> RnM ([HsRecField Name (LPat Name)], FreeVars)
 rnRpats rpats
   = mappM_ field_dup_err dup_fields    `thenM_`
     mapFvRn rn_rpat rpats              `thenM` \ (rpats', fvs) ->
     returnM (rpats', fvs)
   where
-    (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
+    (_, dup_fields) = removeDups compare [ unLoc f | HsRecField f _ _ <- rpats ]
 
     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
 
-    rn_rpat (field, pat)
+    rn_rpat (HsRecField field pat _)
       = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
        rnLPat pat                      `thenM` \ (pat', fvs) ->
-       returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
+       returnM ((mkRecField fieldname pat'), fvs `addOneFV` unLoc fieldname)
 
 \end{code}
 
index 026893c..851d833 100644 (file)
@@ -771,16 +771,16 @@ zonkConStuff env (InfixCon p1 p2)
        ; return (env', InfixCon p1' p2') }
 
 zonkConStuff env (RecCon rpats)
-  = do { (env', pats') <- zonkPats env pats
-       ; returnM (env', RecCon (fields `zip` pats')) }
-  where
-    (fields, pats) = unzip rpats
+  = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _  <- rpats ]
+       ; (env', pats') <- zonkPats env pats
+       ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
+       ; returnM (env', recCon) }
 
 ---------------------------
 zonkPats env []                = return (env, [])
 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
-                            ; (env', pats') <- zonkPats env1 pats
-                            ; return (env', pat':pats') }
+                    ; (env', pats') <- zonkPats env1 pats
+                    ; return (env', pat':pats') }
 \end{code}
 
 %************************************************************************
index 30a47f7..78d0b98 100644 (file)
@@ -357,6 +357,10 @@ kc_hs_type (HsBangTy b ty)
 kc_hs_type ty@(HsSpliceTy _)
   = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty)
 
+-- remove the doc nodes here, no need to worry about the location since
+-- its the same for a doc node and it's child type node
+kc_hs_type (HsDocTy ty _)
+  = kc_hs_type (unLoc ty) 
 
 ---------------------------
 kcApps :: TcKind                       -- Function kind
index a4f3a82..b9099be 100644 (file)
@@ -12,9 +12,10 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit,
 import {-# SOURCE #-}  TcExpr( tcSyntaxOp )
 import HsSyn           ( Pat(..), LPat, HsConDetails(..), HsLit(..),
                          HsOverLit(..), HsExpr(..), HsWrapper(..),
-                         mkCoPat, 
+                         mkCoPat, HsRecField(..), mkRecField,
                          LHsBinds, emptyLHsBinds, isEmptyLHsBinds, 
-                         collectPatsBinders, nlHsLit )
+                         collectPatsBinders, nlHsLit,
+                          LHsDoc )
 import TcHsSyn         ( TcId, hsLitType )
 import TcRnMonad
 import Inst            ( InstOrigin(..), shortCutFracLit, shortCutIntLit, 
@@ -654,11 +655,12 @@ tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside
   = do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
        ; return (RecCon rpats', tvs, res) }
   where
-    tc_field :: Checker (Located Name, LPat Name) (Located TcId, LPat TcId)
-    tc_field (field_lbl, pat) pstate thing_inside
+    -- doc comments are typechecked to Nothing here
+    tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
+    tc_field (HsRecField field_lbl pat _) pstate thing_inside
       = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
           ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
-          ; return ((sel_id, pat'), tvs, res) }
+          ; return (mkRecField sel_id pat', tvs, res) }
 
     find_field_ty :: FieldLabel -> TcM (Id, TcType)
     find_field_ty field_lbl
index fefb21a..b71776b 100644 (file)
@@ -29,7 +29,7 @@ import StaticFlags    ( opt_PprStyle_Debug )
 import HsSyn           ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
                          SpliceDecl(..), HsBind(..), LHsBinds,
                          emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
-                         nlHsApp, nlHsVar, pprLHsBinds )
+                         nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) )
 import RdrHsSyn                ( findSplice )
 
 import PrelNames       ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
@@ -59,6 +59,7 @@ import RnNames                ( importsFromLocalDecls, rnImports, rnExports,
                          reportUnusedNames, reportDeprecations )
 import RnEnv           ( lookupSrcOcc_maybe )
 import RnSource                ( rnSrcDecls, rnTyClDecls, checkModDeprec )
+import RnHsDoc          ( rnMbHsDoc )
 import PprCore         ( pprRules, pprCoreBindings )
 import CoreSyn         ( CoreRule, bindersOfBinds )
 import ErrUtils                ( Messages, mkDumpDoc, showPass )
@@ -155,7 +156,7 @@ tcRnModule :: HscEnv
 
 tcRnModule hsc_env hsc_src save_rn_syntax
         (L loc (HsModule maybe_mod export_ies 
-                         import_decls local_decls mod_deprec))
+                         import_decls local_decls mod_deprec _ module_info maybe_doc))
  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 
    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
@@ -232,7 +233,15 @@ tcRnModule hsc_env hsc_src save_rn_syntax
        reportDeprecations (hsc_dflags hsc_env) tcg_env ;
 
                -- Process the export list
-       rn_exports <- rnExports export_ies;
+       rn_exports <- rnExports export_ies ;
+                 
+               -- Rename the Haddock documentation header 
+       rn_module_doc <- rnMbHsDoc maybe_doc ;
+
+               -- Rename the Haddock module info 
+       rn_description <- rnMbHsDoc (hmi_description module_info) ;
+       let { rn_module_info = module_info { hmi_description = rn_description } } ;
+
         let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
         exports <- mkExportNameSet (isJust maybe_mod) 
                                   (liftM2' (,) rn_exports export_ies) ;
@@ -248,7 +257,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                                                       else Nothing,
                                     tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
                                     tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` 
-                                                  mod_deprecs }
+                                                  mod_deprecs,
+                                    tcg_doc = rn_module_doc, 
+                                    tcg_hmi = rn_module_info
+                                 }
                -- A module deprecation over-rides the earlier ones
             } ;
 
index 3b7a2e8..d9fe12a 100644 (file)
@@ -22,7 +22,7 @@ import NameEnv          ( mkNameEnv )
 import TcEnv            ( tcExtendIdEnv )
 #endif
 
-import HsSyn           ( emptyLHsBinds )
+import HsSyn           ( emptyLHsBinds, HaddockModInfo(..) )
 import HscTypes                ( HscEnv(..), ModGuts(..), ModIface(..),
                          TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
                          ExternalPackageState(..), HomePackageTable,
@@ -120,7 +120,9 @@ initTc hsc_env hsc_src mod do_this
                tcg_rules    = [],
                tcg_fords    = [],
                tcg_dfun_n   = dfun_n_var,
-               tcg_keep     = keep_var
+               tcg_keep     = keep_var,
+               tcg_doc      = Nothing,
+               tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
index 5de2cf4..4283924 100644 (file)
@@ -43,7 +43,7 @@ module TcRnTypes(
 
 import HsSyn           ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
                          ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup,
-                          HsWrapper, IE )
+                          HsWrapper, IE, HsDoc, HaddockModInfo )
 import HscTypes                ( FixityEnv,
                          HscEnv, TypeEnv, TyThing, 
                          GenAvailInfo(..), AvailInfo, HscSource(..),
@@ -227,7 +227,10 @@ data TcGblEnv
        tcg_deprecs :: Deprecations,            -- ...Deprecations 
        tcg_insts   :: [Instance],              -- ...Instances
        tcg_rules   :: [LRuleDecl Id],          -- ...Rules
-       tcg_fords   :: [LForeignDecl Id]        -- ...Foreign import & exports
+       tcg_fords   :: [LForeignDecl Id],       -- ...Foreign import & exports
+
+       tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation
+        tcg_hmi :: HaddockModInfo Name -- Haddock module information
     }
 \end{code}
 
index de5893b..dee20ee 100644 (file)
@@ -11,7 +11,7 @@ module TcTyClsDecls (
 #include "HsVersions.h"
 
 import HsSyn           ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
-                         ConDecl(..),   Sig(..), NewOrData(..), ResType(..),
+                         ConDecl(..), HsRecField(..), Sig(..), NewOrData(..), ResType(..),
                          tyClDeclTyVars, isSynDecl, isIdxTyDecl,
                          isKindSigDecl, hsConArgs, LTyClDecl, tcdName,
                          hsTyVarName, LHsTyVarBndr, LHsType
@@ -572,14 +572,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
        ; cons' <- mappM (wrapLocM kc_con_decl) cons
        ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
   where
-    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do
+    -- doc comments are typechecked to Nothing here
+    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do
       kcHsTyVars ex_tvs $ \ex_tvs' -> do
         ex_ctxt' <- kcHsContext ex_ctxt
         details' <- kc_con_details details 
         res'     <- case res of
           ResTyH98 -> return ResTyH98
           ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
-        return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
+        return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
 
     kc_con_details (PrefixCon btys) 
        = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
@@ -588,7 +589,7 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
     kc_con_details (RecCon fields) 
        = do { fields' <- mappM kc_field fields; return (RecCon fields') }
 
-    kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
+    kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) }
 
     kc_larg_ty bty = case new_or_data of
                        DataType -> kcHsSigType bty
@@ -769,7 +770,7 @@ tcConDecl :: Bool           -- True <=> -funbox-strict_fields
          -> TcM DataCon
 
 tcConDecl unbox_strict NewType tycon tc_tvs    -- Newtypes
-         (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
+         (ConDecl name _ ex_tvs ex_ctxt details ResTyH98 _)
   = do { let tc_datacon field_lbls arg_ty
                = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
                     ; buildDataCon (unLoc name) False {- Prefix -} 
@@ -785,14 +786,14 @@ tcConDecl unbox_strict NewType tycon tc_tvs       -- Newtypes
 
        ; case details of
            PrefixCon [arg_ty]           -> tc_datacon [] arg_ty
-           RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
+           RecCon [HsRecField field_lbl arg_ty _] -> tc_datacon [field_lbl] arg_ty
            other                        -> 
              failWithTc (newtypeFieldErr name (length (hsConArgs details)))
                        -- Check that the constructor has exactly one field
        }
 
 tcConDecl unbox_strict DataType tycon tc_tvs   -- Data types
-         (ConDecl name _ tvs ctxt details res_ty)
+         (ConDecl name _ tvs ctxt details res_ty _)
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
     ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty
@@ -815,7 +816,7 @@ tcConDecl unbox_strict DataType tycon tc_tvs        -- Data types
        InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
        RecCon fields      -> tc_datacon False field_names btys
                           where
-                             (field_names, btys) = unzip fields
+                             (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] 
                               
     }