diff options
40 files changed, 1467 insertions, 280 deletions
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index d1a64f67b7..2bf4ff37a0 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -276,7 +276,7 @@ lexToken = do sc <- getLexState case alexScan inp sc of AlexEOF -> do let span = mkSrcSpan loc1 loc1 - setLastToken span 0 + setLastToken span 0 0 return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexSkip inp2 _ -> do @@ -285,7 +285,7 @@ lexToken = do AlexToken inp2@(end,buf2) len t -> do setInput inp2 let span = mkSrcSpan loc1 end - span `seq` setLastToken span len + span `seq` setLastToken span len len t span buf len -- ----------------------------------------------------------------------------- diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 85b8f9ddd9..dbf2d72dc7 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -151,7 +151,7 @@ untidy b (L loc p) = L loc (untidy' b p) untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) -untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs] +untidy_con (RecCon bs) = RecCon [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ] pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p @@ -687,7 +687,7 @@ simplify_con con (RecCon fs) where -- pad out all the missing fields with WildPats. field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con) - all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc) + all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc) field_pats fs insertNm nm p [] = [(nm,p)] diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 1406d63c6e..b4ecf01eb5 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -289,12 +289,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98)) +repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98 _)) = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98)) +repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc)) = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98)); + c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc)); ctxt' <- repContext ctxt; bndrs' <- coreList nameTyConName bndrs; rep2 forallCName [unC bndrs', unC ctxt', unC c'] @@ -815,8 +815,8 @@ repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) - ; ps <- sequence $ map repLP (map snd pairs) + RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs) + ; ps <- sequence $ map repLP (map hsRecFieldArg pairs) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatQTyConName fps ; repPrec con_str fps' } @@ -1192,8 +1192,8 @@ repConstr con (PrefixCon ps) arg_tys1 <- coreList strictTypeQTyConName arg_tys rep2 normalCName [unC con, unC arg_tys1] repConstr con (RecCon ips) - = do arg_vs <- mapM lookupLOcc (map fst ips) - arg_tys <- mapM repBangTy (map snd ips) + = do arg_vs <- mapM lookupLOcc (map hsRecFieldId ips) + arg_tys <- mapM repBangTy (map hsRecFieldArg ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index fd840e6f93..c4c38b163f 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where import {-# SOURCE #-} Match ( match ) -import HsSyn ( Pat(..), LPat, HsConDetails(..) ) +import HsSyn ( Pat(..), LPat, HsConDetails(..), HsRecField(..) ) import DsBinds ( dsLHsBinds ) import DataCon ( DataCon, dataConInstOrigArgTys, dataConEqSpec, dataConFieldLabels, dataConSourceArity ) @@ -132,7 +132,7 @@ conArgPats data_con arg_tys (RecCon rpats) -- mk_pat picks a WildPat of the appropriate type for absent fields, -- and the specified pattern for present fields mk_pat lbl arg_ty - = case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of + = case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of (pat:pats) -> ASSERT( null pats ) unLoc pat [] -> WildPat arg_ty \end{code} diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index cd5b36d622..dff6a1405b 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -128,8 +128,8 @@ cvtTop (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds ; (binds', sigs') <- cvtBindsAndSigs decs - ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] - -- no ATs in TH^^ + ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] [] + -- no ATs or docs in TH ^^ ^^ } cvtTop (InstanceD tys ty decs) @@ -158,20 +158,20 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing } cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con')) = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con') @@ -181,8 +181,8 @@ cvtConstr (ForallC tvs ctxt con) ; tvs' <- cvtTvs tvs ; ctxt' <- cvtContext ctxt ; case con' of - ConDecl l _ [] (L _ []) x ResTyH98 - -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 + ConDecl l _ [] (L _ []) x ResTyH98 _ + -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing c -> panic "ForallC: Can't happen" } cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } @@ -190,7 +190,7 @@ cvt_arg (NotStrict, ty) = cvtType ty cvt_id_arg (i, str, ty) = do { i' <- vNameL i ; ty' <- cvt_arg (str,ty) - ; return (i', ty') } + ; return (mkRecField i' ty') } cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs @@ -458,7 +458,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } -cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') } +cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField s' p') } ----------------------------------------------------------- -- Types and type variables diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 0588047695..884552238d 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -439,13 +439,14 @@ sigForThisGroup ns sig Just n -> n `elemNameSet` ns sigName :: LSig name -> Maybe name -sigName (L _ sig) = f sig - where - f (TypeSig n _) = Just (unLoc n) - f (SpecSig n _ _) = Just (unLoc n) - f (InlineSig n _) = Just (unLoc n) - f (FixSig (FixitySig n _)) = Just (unLoc n) - f other = Nothing +sigName (L _ sig) = sigNameNoLoc sig + +sigNameNoLoc :: Sig name -> Maybe name +sigNameNoLoc (TypeSig n _) = Just (unLoc n) +sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) +sigNameNoLoc (InlineSig n _) = Just (unLoc n) +sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n) +sigNameNoLoc other = Nothing isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 9543cadfca..733a8ea8be 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -15,6 +15,7 @@ module HsDecls ( ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), ConDecl(..), ResType(..), LConDecl, + DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..), DeprecDecl(..), LDeprecDecl, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, tcdName, tyClDeclNames, tyClDeclTyVars, @@ -35,9 +36,10 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds, Sig(..), LSig, LFixitySig, pprLHsBinds, emptyValBindsIn, emptyValBindsOut ) -import HsPat ( HsConDetails(..), hsConArgs ) +import HsPat ( HsConDetails(..), hsConArgs, HsRecField(..) ) import HsImpExp ( pprHsVar ) import HsTypes +import HsDoc ( HsDoc, LHsDoc, ppr_mbDoc ) import NameSet ( NameSet ) import CoreSyn ( RuleName ) import {- Kind parts of -} Type ( Kind, pprKind ) @@ -54,7 +56,6 @@ import FastString import Maybe ( isJust ) \end{code} - %************************************************************************ %* * \subsection[HsDecl]{Declarations} @@ -75,6 +76,8 @@ data HsDecl id | DeprecD (DeprecDecl id) | RuleD (RuleDecl id) | SpliceD (SpliceDecl id) + | DocD (DocDecl id) + -- NB: all top-level fixity decls are contained EITHER -- EITHER SigDs @@ -105,7 +108,11 @@ data HsGroup id hs_defds :: [LDefaultDecl id], hs_fords :: [LForeignDecl id], hs_depds :: [LDeprecDecl id], - hs_ruleds :: [LRuleDecl id] + hs_ruleds :: [LRuleDecl id], + + hs_docs :: [DocEntity id] + -- Used to remember the module structure, + -- which is needed to produce Haddock documentation } emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a @@ -115,7 +122,8 @@ emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_fords = [], hs_depds = [], hs_ruleds = [], - hs_valds = error "emptyGroup hs_valds: Can't happen" } + hs_valds = error "emptyGroup hs_valds: Can't happen", + hs_docs = [] } appendGroups :: HsGroup a -> HsGroup a -> HsGroup a appendGroups @@ -128,7 +136,8 @@ appendGroups hs_defds = defds1, hs_fords = fords1, hs_depds = depds1, - hs_ruleds = rulds1 } + hs_ruleds = rulds1, + hs_docs = docs1 } HsGroup { hs_valds = val_groups2, hs_tyclds = tyclds2, @@ -138,7 +147,8 @@ appendGroups hs_defds = defds2, hs_fords = fords2, hs_depds = depds2, - hs_ruleds = rulds2 } + hs_ruleds = rulds2, + hs_docs = docs2 } = HsGroup { hs_valds = val_groups1 `plusHsValBinds` val_groups2, @@ -149,21 +159,23 @@ appendGroups hs_defds = defds1 ++ defds2, hs_fords = fords1 ++ fords2, hs_depds = depds1 ++ depds2, - hs_ruleds = rulds1 ++ rulds2 } + hs_ruleds = rulds1 ++ rulds2, + hs_docs = docs1 ++ docs2 } \end{code} \begin{code} instance OutputableBndr name => Outputable (HsDecl name) where - ppr (TyClD dcl) = ppr dcl - ppr (ValD binds) = ppr binds - ppr (DefD def) = ppr def - ppr (InstD inst) = ppr inst - ppr (DerivD deriv) = ppr deriv - ppr (ForD fd) = ppr fd - ppr (SigD sd) = ppr sd - ppr (RuleD rd) = ppr rd - ppr (DeprecD dd) = ppr dd - ppr (SpliceD dd) = ppr dd + ppr (TyClD dcl) = ppr dcl + ppr (ValD binds) = ppr binds + ppr (DefD def) = ppr def + ppr (InstD inst) = ppr inst + ppr (DerivD deriv) = ppr deriv + ppr (ForD fd) = ppr fd + ppr (SigD sd) = ppr sd + ppr (RuleD rd) = ppr rd + ppr (DeprecD dd) = ppr dd + ppr (SpliceD dd) = ppr dd + ppr (DocD doc) = ppr doc instance OutputableBndr name => Outputable (HsGroup name) where ppr (HsGroup { hs_valds = val_decls, @@ -414,10 +426,11 @@ data TyClDecl name tcdFDs :: [Located (FunDep name)], -- Functional deps tcdSigs :: [LSig name], -- Methods' signatures tcdMeths :: LHsBinds name, -- Default methods - tcdATs :: [LTyClDecl name] -- Associated types; ie + tcdATs :: [LTyClDecl name], -- Associated types; ie -- only 'TyData', -- 'TyFunction', -- and 'TySynonym' + tcdDocs :: [DocEntity name] -- Haddock docs } data NewOrData @@ -638,6 +651,8 @@ data ConDecl name , con_details :: HsConDetails name (LBangType name) -- The main payload , con_res :: ResType name -- Result type of the constructor + + , con_doc :: Maybe (LHsDoc name) -- A possible Haddock comment } data ResType name @@ -657,7 +672,7 @@ conDeclsNames cons do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds }) = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc) where - new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ] + new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ] do_one (flds_seen, acc) c = (flds_seen, (con_name c):acc) @@ -670,23 +685,23 @@ conDetailsTys details = map getBangType (hsConArgs details) instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl -pprConDecl (ConDecl con expl tvs cxt details ResTyH98) - = sep [pprHsForAll expl tvs cxt, ppr_details con details] +pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc) + = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] where ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2] ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields -pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty)) +pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _) = ppr con <+> dcolon <+> sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] where mk_fun_ty a b = noLoc (HsFunTy a b) -pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty)) - = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr fields <+> dcolon <+> ppr res_ty] -ppr_fields fields = braces (sep (punctuate comma (map ppr_field fields))) -ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty +pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _) + = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty] + +ppr_fields fields = braces (sep (punctuate comma (map ppr fields))) \end{code} %************************************************************************ @@ -909,6 +924,37 @@ instance OutputableBndr name => Outputable (RuleBndr name) where ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty \end{code} +%************************************************************************ +%* * +\subsection[DocDecl]{Document comments} +%* * +%************************************************************************ + +\begin{code} + +-- source code entities, for representing the module structure +data DocEntity name + = DeclEntity name + | DocEntity (DocDecl name) + +type LDocDecl name = Located (DocDecl name) + +data DocDecl name + = DocCommentNext (HsDoc name) + | DocCommentPrev (HsDoc name) + | DocCommentNamed String (HsDoc name) + | DocGroup Int (HsDoc name) + +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable (DocDecl name) where + ppr _ = text "<document comment>" + +docDeclDoc (DocCommentNext d) = d +docDeclDoc (DocCommentPrev d) = d +docDeclDoc (DocCommentNamed _ d) = d +docDeclDoc (DocGroup _ d) = d + +\end{code} %************************************************************************ %* * diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs new file mode 100644 index 0000000000..51ef579a75 --- /dev/null +++ b/compiler/hsSyn/HsDoc.hs @@ -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 diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index f63d86aec2..767be42d29 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -9,6 +9,8 @@ module HsImpExp where #include "HsVersions.h" import Module ( ModuleName ) +import HsDoc ( HsDoc ) + import Outputable import FastString import SrcLoc ( Located(..) ) @@ -68,11 +70,14 @@ ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm type LIE name = Located (IE name) data IE name - = IEVar name - | IEThingAbs name -- Class/Type (can't tell) - | IEThingAll name -- Class/Type plus all methods/constructors - | IEThingWith name [name] -- Class/Type plus some methods/constructors - | IEModuleContents ModuleName -- (Export Only) + = IEVar name + | IEThingAbs name -- Class/Type (can't tell) + | IEThingAll name -- Class/Type plus all methods/constructors + | IEThingWith name [name] -- Class/Type plus some methods/constructors + | IEModuleContents ModuleName -- (Export Only) + | IEGroup Int (HsDoc name) -- Doc section heading + | IEDoc (HsDoc name) -- Some documentation + | IEDocNamed String -- Reference to named doc \end{code} \begin{code} @@ -88,6 +93,9 @@ ieNames (IEThingAbs n ) = [n] ieNames (IEThingAll n ) = [n] ieNames (IEThingWith n ns) = n:ns ieNames (IEModuleContents _ ) = [] +ieNames (IEGroup _ _ ) = [] +ieNames (IEDoc _ ) = [] +ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} @@ -99,6 +107,9 @@ instance (Outputable name) => Outputable (IE name) where = ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs))) ppr (IEModuleContents mod) = ptext SLIT("module") <+> ppr mod + ppr (IEGroup n doc) = text ("<IEGroup: " ++ (show n) ++ ">") + ppr (IEDoc doc) = ppr doc + ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">") \end{code} \begin{code} diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 79b906207b..f2ba6b342e 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -8,6 +8,7 @@ module HsPat ( Pat(..), InPat, OutPat, LPat, HsConDetails(..), hsConArgs, + HsRecField(..), mkRecField, mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, @@ -26,6 +27,7 @@ import HsBinds ( DictBinds, HsBind(..), HsWrapper, isIdHsWrapper, pprHsWrapper, emptyLHsBinds, pprLHsBinds ) import HsLit ( HsLit(HsCharPrim), HsOverLit ) import HsTypes ( LHsType, PostTcType ) +import HsDoc ( LHsDoc, ppr_mbDoc ) import BasicTypes ( Boxity, tupleParens ) -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) @@ -138,13 +140,21 @@ HsConDetails is use both for patterns and for data type declarations \begin{code} data HsConDetails id arg - = PrefixCon [arg] -- C p1 p2 p3 - | RecCon [(Located id, arg)] -- C { x = p1, y = p2 } - | InfixCon arg arg -- p1 `C` p2 + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon [HsRecField id arg] -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + +data HsRecField id arg = HsRecField { + hsRecFieldId :: Located id, + hsRecFieldArg :: arg, + hsRecFieldDoc :: Maybe (LHsDoc id) +} + +mkRecField id arg = HsRecField id arg Nothing hsConArgs :: HsConDetails id arg -> [arg] hsConArgs (PrefixCon ps) = ps -hsConArgs (RecCon fs) = map snd fs +hsConArgs (RecCon fs) = map hsRecFieldArg fs hsConArgs (InfixCon p1 p2) = [p1,p2] \end{code} @@ -209,13 +219,17 @@ pprConArgs (PrefixCon pats) = interppSP pats pprConArgs (InfixCon p1 p2) = interppSP [p1,p2] pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats))) where - pp_rpat (v, p) = hsep [ppr v, char '=', ppr p] - + pp_rpat (HsRecField v p d) = + hsep [ppr d, ppr v, char '=', ppr p] -- add parallel array brackets around a document -- pabrackets :: SDoc -> SDoc pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") + +instance (OutputableBndr id, Outputable arg) => + Outputable (HsRecField id arg) where + ppr (HsRecField n ty doc) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 2169b1a3b6..fb5162a73b 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -17,10 +17,14 @@ module HsSyn ( module HsPat, module HsTypes, module HsUtils, + module HsDoc, Fixity, - HsModule(..), HsExtCore(..) - ) where + HsModule(..), HsExtCore(..), + + HaddockModInfo(..), + emptyHaddockModInfo, +) where #include "HsVersions.h" @@ -34,6 +38,7 @@ import HsPat import HsTypes import BasicTypes ( Fixity, DeprecTxt ) import HsUtils +import HsDoc -- others: import IfaceSyn ( IfaceBinding ) @@ -57,6 +62,24 @@ data HsModule name -- often empty, downstream. [LHsDecl name] -- Type, class, value, and interface signature decls (Maybe DeprecTxt) -- reason/explanation for deprecation of this module + (Maybe String) -- Haddock options, declared with the {-# DOCOPTIONS ... #-} pragma + (HaddockModInfo name) -- Haddock module info + (Maybe (HsDoc name)) -- Haddock module description + +data HaddockModInfo name = HaddockModInfo { + hmi_description :: Maybe (HsDoc name), + hmi_portability :: Maybe String, + hmi_stability :: Maybe String, + hmi_maintainer :: Maybe String +} + +emptyHaddockModInfo :: HaddockModInfo a +emptyHaddockModInfo = HaddockModInfo { + hmi_description = Nothing, + hmi_portability = Nothing, + hmi_stability = Nothing, + hmi_maintainer = Nothing +} data HsExtCore name -- Read from Foo.hcr = HsExtCore @@ -66,15 +89,20 @@ data HsExtCore name -- Read from Foo.hcr [IfaceBinding] -- And the bindings \end{code} + \begin{code} +instance Outputable Char where + ppr c = text [c] + instance (OutputableBndr name) => Outputable (HsModule name) where - ppr (HsModule Nothing _ imports decls _) - = pp_nonnull imports $$ pp_nonnull decls + ppr (HsModule Nothing _ imports decls _ _ _ mbDoc) + = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule (Just name) exports imports decls deprec) + ppr (HsModule (Just name) exports imports decls deprec opts _ mbDoc) = vcat [ + pp_mb mbDoc, case exports of Nothing -> pp_header (ptext SLIT("where")) 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} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 2693a101d2..ad7facb11e 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index da0e24c6c1..5d7132ec74 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -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} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d93e9443e2..9a8804aa0b 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 250187afbe..dab148a7a5 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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: diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 847d193c28..48eda22452 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 55d84b4059..bea07c04ca 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -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, diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 5ceef37332..ee8717faf1 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -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 diff --git a/compiler/package.conf.in b/compiler/package.conf.in index b915ce44e2..383ed851b6 100644 --- a/compiler/package.conf.in +++ b/compiler/package.conf.in @@ -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 index 0000000000..abfc2d6667 --- /dev/null +++ b/compiler/parser/HaddockLex.hs-boot @@ -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 index 0000000000..e4c2d2d933 --- /dev/null +++ b/compiler/parser/HaddockLex.x @@ -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 index 0000000000..f6c80cb494 --- /dev/null +++ b/compiler/parser/HaddockParse.y @@ -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 index 0000000000..72ea20d7be --- /dev/null +++ b/compiler/parser/HaddockUtils.hs @@ -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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 15745d5620..4806a8a3ef 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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") diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 18565a9547..7166e1e70b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index a6ee5ddc89..dd3d8b7543 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -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 -} { [] } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 87741b950d..8e4570a7c0 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index b21c42d2f1..29a87918f8 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -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 index 0000000000..6941da59c1 --- /dev/null +++ b/compiler/rename/RnHsDoc.hs @@ -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) diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 6752218b29..53f04e2ba2 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -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} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 71890dba24..a6b021df8f 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -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 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9a3e80520e..670cfc8092 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 0aa0b4e1c5..fe51c1af32 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -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} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 026893c86c..851d833fce 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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} %************************************************************************ diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 30a47f7a5d..78d0b98944 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -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 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index a4f3a82521..b9099beb55 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index fefb21aecf..b71776bde4 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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 } ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 3b7a2e8379..d9fe12aa2f 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 5de2cf49f4..428392444c 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -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} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index de5893b071..dee20eee88 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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 ] } |