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

parent aa8e9422
...@@ -276,7 +276,7 @@ lexToken = do ...@@ -276,7 +276,7 @@ lexToken = do
sc <- getLexState sc <- getLexState
case alexScan inp sc of case alexScan inp sc of
AlexEOF -> do let span = mkSrcSpan loc1 loc1 AlexEOF -> do let span = mkSrcSpan loc1 loc1
setLastToken span 0 setLastToken span 0 0
return (L span CmmT_EOF) return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
AlexSkip inp2 _ -> do AlexSkip inp2 _ -> do
...@@ -285,7 +285,7 @@ lexToken = do ...@@ -285,7 +285,7 @@ lexToken = do
AlexToken inp2@(end,buf2) len t -> do AlexToken inp2@(end,buf2) len t -> do
setInput inp2 setInput inp2
let span = mkSrcSpan loc1 end let span = mkSrcSpan loc1 end
span `seq` setLastToken span len span `seq` setLastToken span len len
t span buf len t span buf len
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -151,7 +151,7 @@ untidy b (L loc p) = L loc (untidy' b p) ...@@ -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 (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) 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 :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p pars True p = ParPat p
...@@ -687,7 +687,7 @@ simplify_con con (RecCon fs) ...@@ -687,7 +687,7 @@ simplify_con con (RecCon fs)
where where
-- pad out all the missing fields with WildPats. -- pad out all the missing fields with WildPats.
field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con) 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 field_pats fs
insertNm nm p [] = [(nm,p)] insertNm nm p [] = [(nm,p)]
......
...@@ -289,12 +289,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") ...@@ -289,12 +289,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
------------------------------------------------------- -------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ) 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] = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details } 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 { = 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; ctxt' <- repContext ctxt;
bndrs' <- coreList nameTyConName bndrs; bndrs' <- coreList nameTyConName bndrs;
rep2 forallCName [unC bndrs', unC ctxt', unC c'] rep2 forallCName [unC bndrs', unC ctxt', unC c']
...@@ -815,8 +815,8 @@ repP (ConPatIn dc details) ...@@ -815,8 +815,8 @@ repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc = do { con_str <- lookupLOcc dc
; case details of ; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
; ps <- sequence $ map repLP (map snd pairs) ; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
; fps' <- coreList fieldPatQTyConName fps ; fps' <- coreList fieldPatQTyConName fps
; repPrec con_str fps' } ; repPrec con_str fps' }
...@@ -1192,8 +1192,8 @@ repConstr con (PrefixCon ps) ...@@ -1192,8 +1192,8 @@ repConstr con (PrefixCon ps)
arg_tys1 <- coreList strictTypeQTyConName arg_tys arg_tys1 <- coreList strictTypeQTyConName arg_tys
rep2 normalCName [unC con, unC arg_tys1] rep2 normalCName [unC con, unC arg_tys1]
repConstr con (RecCon ips) repConstr con (RecCon ips)
= do arg_vs <- mapM lookupLOcc (map fst ips) = do arg_vs <- mapM lookupLOcc (map hsRecFieldId ips)
arg_tys <- mapM repBangTy (map snd ips) arg_tys <- mapM repBangTy (map hsRecFieldArg ips)
arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
arg_vs arg_tys arg_vs arg_tys
arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
......
...@@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where ...@@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where
import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} Match ( match )
import HsSyn ( Pat(..), LPat, HsConDetails(..) ) import HsSyn ( Pat(..), LPat, HsConDetails(..), HsRecField(..) )
import DsBinds ( dsLHsBinds ) import DsBinds ( dsLHsBinds )
import DataCon ( DataCon, dataConInstOrigArgTys, dataConEqSpec, import DataCon ( DataCon, dataConInstOrigArgTys, dataConEqSpec,
dataConFieldLabels, dataConSourceArity ) dataConFieldLabels, dataConSourceArity )
...@@ -132,7 +132,7 @@ conArgPats data_con arg_tys (RecCon rpats) ...@@ -132,7 +132,7 @@ conArgPats data_con arg_tys (RecCon rpats)
-- mk_pat picks a WildPat of the appropriate type for absent fields, -- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields -- and the specified pattern for present fields
mk_pat lbl arg_ty 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 (pat:pats) -> ASSERT( null pats ) unLoc pat
[] -> WildPat arg_ty [] -> WildPat arg_ty
\end{code} \end{code}
......
...@@ -128,8 +128,8 @@ cvtTop (ClassD ctxt cl tvs fds decs) ...@@ -128,8 +128,8 @@ cvtTop (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs = do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds ; fds' <- mapM cvt_fundep fds
; (binds', sigs') <- cvtBindsAndSigs decs ; (binds', sigs') <- cvtBindsAndSigs decs
; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
-- no ATs in TH^^ -- no ATs or docs in TH ^^ ^^
} }
cvtTop (InstanceD tys ty decs) cvtTop (InstanceD tys ty decs)
...@@ -158,20 +158,20 @@ cvtConstr (NormalC c strtys) ...@@ -158,20 +158,20 @@ cvtConstr (NormalC c strtys)
= do { c' <- cNameL c = do { c' <- cNameL c
; cxt' <- returnL [] ; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys ; 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) cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c = do { c' <- cNameL c
; cxt' <- returnL [] ; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys ; 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) cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c = do { c' <- cNameL c
; cxt' <- returnL [] ; cxt' <- returnL []
; st1' <- cvt_arg st1 ; st1' <- cvt_arg st1
; st2' <- cvt_arg st2 ; 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 ctxt (ForallC tvs' ctxt' con'))
= cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con') = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
...@@ -181,8 +181,8 @@ cvtConstr (ForallC tvs ctxt con) ...@@ -181,8 +181,8 @@ cvtConstr (ForallC tvs ctxt con)
; tvs' <- cvtTvs tvs ; tvs' <- cvtTvs tvs
; ctxt' <- cvtContext ctxt ; ctxt' <- cvtContext ctxt
; case con' of ; case con' of
ConDecl l _ [] (L _ []) x ResTyH98 ConDecl l _ [] (L _ []) x ResTyH98 _
-> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
c -> panic "ForallC: Can't happen" } c -> panic "ForallC: Can't happen" }
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
...@@ -190,7 +190,7 @@ cvt_arg (NotStrict, ty) = cvtType ty ...@@ -190,7 +190,7 @@ cvt_arg (NotStrict, ty) = cvtType ty
cvt_id_arg (i, str, ty) = do { i' <- vNameL i cvt_id_arg (i, str, ty) = do { i' <- vNameL i
; ty' <- cvt_arg (str,ty) ; ty' <- cvt_arg (str,ty)
; return (i', ty') } ; return (mkRecField i' ty') }
cvtDerivs [] = return Nothing cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs cvtDerivs cs = do { cs' <- mapM cvt_one cs
...@@ -458,7 +458,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ...@@ -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 (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' } 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 -- Types and type variables
......
...@@ -439,13 +439,14 @@ sigForThisGroup ns sig ...@@ -439,13 +439,14 @@ sigForThisGroup ns sig
Just n -> n `elemNameSet` ns Just n -> n `elemNameSet` ns
sigName :: LSig name -> Maybe name sigName :: LSig name -> Maybe name
sigName (L _ sig) = f sig sigName (L _ sig) = sigNameNoLoc sig
where
f (TypeSig n _) = Just (unLoc n) sigNameNoLoc :: Sig name -> Maybe name
f (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (TypeSig n _) = Just (unLoc n)
f (InlineSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
f (FixSig (FixitySig n _)) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n)
f other = Nothing sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
sigNameNoLoc other = Nothing
isFixityLSig :: LSig name -> Bool isFixityLSig :: LSig name -> Bool
isFixityLSig (L _ (FixSig {})) = True isFixityLSig (L _ (FixSig {})) = True
......
...@@ -15,6 +15,7 @@ module HsDecls ( ...@@ -15,6 +15,7 @@ module HsDecls (
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..), CImportSpec(..), FoType(..),
ConDecl(..), ResType(..), LConDecl, ConDecl(..), ResType(..), LConDecl,
DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..),
DeprecDecl(..), LDeprecDecl, DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars, tcdName, tyClDeclNames, tyClDeclTyVars,
...@@ -35,9 +36,10 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) ...@@ -35,9 +36,10 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds, import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds,
Sig(..), LSig, LFixitySig, pprLHsBinds, Sig(..), LSig, LFixitySig, pprLHsBinds,
emptyValBindsIn, emptyValBindsOut ) emptyValBindsIn, emptyValBindsOut )
import HsPat ( HsConDetails(..), hsConArgs ) import HsPat ( HsConDetails(..), hsConArgs, HsRecField(..) )
import HsImpExp ( pprHsVar ) import HsImpExp ( pprHsVar )
import HsTypes import HsTypes
import HsDoc ( HsDoc, LHsDoc, ppr_mbDoc )
import NameSet ( NameSet ) import NameSet ( NameSet )
import CoreSyn ( RuleName ) import CoreSyn ( RuleName )
import {- Kind parts of -} Type ( Kind, pprKind ) import {- Kind parts of -} Type ( Kind, pprKind )
...@@ -54,7 +56,6 @@ import FastString ...@@ -54,7 +56,6 @@ import FastString
import Maybe ( isJust ) import Maybe ( isJust )
\end{code} \end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection[HsDecl]{Declarations} \subsection[HsDecl]{Declarations}
...@@ -75,6 +76,8 @@ data HsDecl id ...@@ -75,6 +76,8 @@ data HsDecl id
| DeprecD (DeprecDecl id) | DeprecD (DeprecDecl id)
| RuleD (RuleDecl id) | RuleD (RuleDecl id)
| SpliceD (SpliceDecl id) | SpliceD (SpliceDecl id)
| DocD (DocDecl id)
-- NB: all top-level fixity decls are contained EITHER -- NB: all top-level fixity decls are contained EITHER
-- EITHER SigDs -- EITHER SigDs
...@@ -105,7 +108,11 @@ data HsGroup id ...@@ -105,7 +108,11 @@ data HsGroup id
hs_defds :: [LDefaultDecl id], hs_defds :: [LDefaultDecl id],
hs_fords :: [LForeignDecl id], hs_fords :: [LForeignDecl id],
hs_depds :: [LDeprecDecl 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 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
...@@ -115,7 +122,8 @@ emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } ...@@ -115,7 +122,8 @@ emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_fords = [], hs_fixds = [], hs_defds = [], hs_fords = [],
hs_depds = [], hs_ruleds = [], 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 :: HsGroup a -> HsGroup a -> HsGroup a
appendGroups appendGroups
...@@ -128,7 +136,8 @@ appendGroups ...@@ -128,7 +136,8 @@ appendGroups
hs_defds = defds1, hs_defds = defds1,
hs_fords = fords1, hs_fords = fords1,
hs_depds = depds1, hs_depds = depds1,
hs_ruleds = rulds1 } hs_ruleds = rulds1,
hs_docs = docs1 }
HsGroup { HsGroup {
hs_valds = val_groups2, hs_valds = val_groups2,
hs_tyclds = tyclds2, hs_tyclds = tyclds2,
...@@ -138,7 +147,8 @@ appendGroups ...@@ -138,7 +147,8 @@ appendGroups
hs_defds = defds2, hs_defds = defds2,
hs_fords = fords2, hs_fords = fords2,
hs_depds = depds2, hs_depds = depds2,
hs_ruleds = rulds2 } hs_ruleds = rulds2,
hs_docs = docs2 }
= =
HsGroup { HsGroup {
hs_valds = val_groups1 `plusHsValBinds` val_groups2, hs_valds = val_groups1 `plusHsValBinds` val_groups2,
...@@ -149,21 +159,23 @@ appendGroups ...@@ -149,21 +159,23 @@ appendGroups
hs_defds = defds1 ++ defds2, hs_defds = defds1 ++ defds2,
hs_fords = fords1 ++ fords2, hs_fords = fords1 ++ fords2,
hs_depds = depds1 ++ depds2, hs_depds = depds1 ++ depds2,
hs_ruleds = rulds1 ++ rulds2 } hs_ruleds = rulds1 ++ rulds2,
hs_docs = docs1 ++ docs2 }
\end{code} \end{code}
\begin{code} \begin{code}
instance OutputableBndr name => Outputable (HsDecl name) where instance OutputableBndr name => Outputable (HsDecl name) where
ppr (TyClD dcl) = ppr dcl ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst ppr (InstD inst) = ppr inst
ppr (DerivD deriv) = ppr deriv ppr (DerivD deriv) = ppr deriv
ppr (ForD fd) = ppr fd ppr (ForD fd) = ppr fd
ppr (SigD sd) = ppr sd ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd ppr (DeprecD dd) = ppr dd
ppr (SpliceD dd) = ppr dd ppr (SpliceD dd) = ppr dd
ppr (DocD doc) = ppr doc
instance OutputableBndr name => Outputable (HsGroup name) where instance OutputableBndr name => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls, ppr (HsGroup { hs_valds = val_decls,
...@@ -414,10 +426,11 @@ data TyClDecl name ...@@ -414,10 +426,11 @@ data TyClDecl name
tcdFDs :: [Located (FunDep name)], -- Functional deps tcdFDs :: [Located (FunDep name)], -- Functional deps
tcdSigs :: [LSig name], -- Methods' signatures tcdSigs :: [LSig name], -- Methods' signatures
tcdMeths :: LHsBinds name, -- Default methods tcdMeths :: LHsBinds name, -- Default methods
tcdATs :: [LTyClDecl name] -- Associated types; ie tcdATs :: [LTyClDecl name], -- Associated types; ie
-- only 'TyData', -- only 'TyData',
-- 'TyFunction', -- 'TyFunction',
-- and 'TySynonym' -- and 'TySynonym'
tcdDocs :: [DocEntity name] -- Haddock docs
} }
data NewOrData data NewOrData
...@@ -638,6 +651,8 @@ data ConDecl name ...@@ -638,6 +651,8 @@ data ConDecl name
, con_details :: HsConDetails name (LBangType name) -- The main payload , con_details :: HsConDetails name (LBangType name) -- The main payload
, con_res :: ResType name -- Result type of the constructor , con_res :: ResType name -- Result type of the constructor
, con_doc :: Maybe (LHsDoc name) -- A possible Haddock comment
} }
data ResType name data ResType name
...@@ -657,7 +672,7 @@ conDeclsNames cons ...@@ -657,7 +672,7 @@ conDeclsNames cons
do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds }) 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) = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc)
where 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 do_one (flds_seen, acc) c
= (flds_seen, (con_name c):acc) = (flds_seen, (con_name c):acc)
...@@ -670,23 +685,23 @@ conDetailsTys details = map getBangType (hsConArgs details) ...@@ -670,23 +685,23 @@ conDetailsTys details = map getBangType (hsConArgs details)
instance (OutputableBndr name) => Outputable (ConDecl name) where instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl ppr = pprConDecl
pprConDecl (ConDecl con expl tvs cxt details ResTyH98) pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
= sep [pprHsForAll expl tvs cxt, ppr_details con details] = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where where
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2] 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 (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields 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 <+> = ppr con <+> dcolon <+>
sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
where where
mk_fun_ty a b = noLoc (HsFunTy a b) 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))) pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
ppr_field (n, ty) = ppr n <+> dcolon <+> ppr 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} \end{code}
%************************************************************************ %************************************************************************
...@@ -909,6 +924,37 @@ instance OutputableBndr name => Outputable (RuleBndr name) where ...@@ -909,6 +924,37 @@ instance OutputableBndr name => Outputable (RuleBndr name) where
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
\end{code} \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}
%************************************************************************ %************************************************************************
%* * %* *
......
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
...@@ -9,6 +9,8 @@ module HsImpExp where ...@@ -9,6 +9,8 @@ module HsImpExp where
#include "HsVersions.h" #include "HsVersions.h"
import Module ( ModuleName ) import Module ( ModuleName )
import HsDoc ( HsDoc )
import Outputable import Outputable
import FastString import FastString
import SrcLoc ( Located(..) ) import SrcLoc ( Located(..) )
...@@ -68,11 +70,14 @@ ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm ...@@ -68,11 +70,14 @@ ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm
type LIE name = Located (IE name) type LIE name = Located (IE name)
data IE name data IE name
= IEVar name = IEVar name
| IEThingAbs name -- Class/Type (can't tell) | IEThingAbs name -- Class/Type (can't tell)
| IEThingAll name -- Class/Type plus all methods/constructors | IEThingAll name -- Class/Type plus all methods/constructors
| IEThingWith name [name] -- Class/Type plus some methods/constructors | IEThingWith name [name] -- Class/Type plus some methods/constructors
| IEModuleContents ModuleName -- (Export Only) | IEModuleContents ModuleName -- (Export Only)
| IEGroup Int (HsDoc name) -- Doc section heading