Skip to content

GitLab

GHC
GHC
Commit 190f2489 authored by davve@dtek.chalmers.se's avatar davve@dtek.chalmers.se
Browse files
Options

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

parent aa8e9422
Hide whitespace changes
Inline Side-by-side
Showing with 1467 additions and 280 deletions
compiler/cmm/CmmLex.x
View file @ 190f2489
......@@ -276,7 +276,7 @@ lexToken = do
sc <- getLexState
case alexScan inp sc of
AlexEOF -> do let span = mkSrcSpan loc1 loc1
setLastToken span 0
setLastToken span 0 0
return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
AlexSkip inp2 _ -> do
......@@ -285,7 +285,7 @@ lexToken = do
AlexToken inp2@(end,buf2) len t -> do
setInput inp2
let span = mkSrcSpan loc1 end
span `seq` setLastToken span len
span `seq` setLastToken span len len
t span buf len
-- -----------------------------------------------------------------------------
......
compiler/deSugar/Check.lhs
View file @ 190f2489
......@@ -151,7 +151,7 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs]
untidy_con (RecCon bs) = RecCon [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ]
pars :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p
......@@ -687,7 +687,7 @@ simplify_con con (RecCon fs)
where
-- pad out all the missing fields with WildPats.
field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con)
all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
field_pats fs
insertNm nm p [] = [(nm,p)]
......
compiler/deSugar/DsMeta.hs
View file @ 190f2489
......@@ -289,12 +289,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
-------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98 _))
= do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
= do { addTyVarBinds tvs $ \bndrs -> do {
c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
ctxt' <- repContext ctxt;
bndrs' <- coreList nameTyConName bndrs;
rep2 forallCName [unC bndrs', unC ctxt', unC c']
......@@ -815,8 +815,8 @@ repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
; ps <- sequence $ map repLP (map snd pairs)
RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
; fps' <- coreList fieldPatQTyConName fps
; repPrec con_str fps' }
......@@ -1192,8 +1192,8 @@ repConstr con (PrefixCon ps)
arg_tys1 <- coreList strictTypeQTyConName arg_tys
rep2 normalCName [unC con, unC arg_tys1]
repConstr con (RecCon ips)
= do arg_vs <- mapM lookupLOcc (map fst ips)
arg_tys <- mapM repBangTy (map snd ips)
= do arg_vs <- mapM lookupLOcc (map hsRecFieldId ips)
arg_tys <- mapM repBangTy (map hsRecFieldArg ips)
arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
arg_vs arg_tys
arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
......
compiler/deSugar/MatchCon.lhs
View file @ 190f2489
......@@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where
import {-# SOURCE #-} Match ( match )
import HsSyn ( Pat(..), LPat, HsConDetails(..) )
import HsSyn ( Pat(..), LPat, HsConDetails(..), HsRecField(..) )
import DsBinds ( dsLHsBinds )
import DataCon ( DataCon, dataConInstOrigArgTys, dataConEqSpec,
dataConFieldLabels, dataConSourceArity )
......@@ -132,7 +132,7 @@ conArgPats data_con arg_tys (RecCon rpats)
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
mk_pat lbl arg_ty
= case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of
= case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of
(pat:pats) -> ASSERT( null pats ) unLoc pat
[] -> WildPat arg_ty
\end{code}
......
compiler/hsSyn/Convert.lhs
View file @ 190f2489
......@@ -128,8 +128,8 @@ cvtTop (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs') <- cvtBindsAndSigs decs
; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' []
-- no ATs in TH^^
; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
-- no ATs or docs in TH ^^ ^^
}
cvtTop (InstanceD tys ty decs)
......@@ -158,20 +158,20 @@ cvtConstr (NormalC c strtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys
; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 }
; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 }
; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
; cxt' <- returnL []
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 }
; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
= cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
......@@ -181,8 +181,8 @@ cvtConstr (ForallC tvs ctxt con)
; tvs' <- cvtTvs tvs
; ctxt' <- cvtContext ctxt
; case con' of
ConDecl l _ [] (L _ []) x ResTyH98
-> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98
ConDecl l _ [] (L _ []) x ResTyH98 _
-> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
c -> panic "ForallC: Can't happen" }
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
......@@ -190,7 +190,7 @@ cvt_arg (NotStrict, ty) = cvtType ty
cvt_id_arg (i, str, ty) = do { i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return (i', ty') }
; return (mkRecField i' ty') }
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
......@@ -458,7 +458,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') }
cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField s' p') }
-----------------------------------------------------------
-- Types and type variables
......
compiler/hsSyn/HsBinds.lhs
View file @ 190f2489
......@@ -439,13 +439,14 @@ sigForThisGroup ns sig
Just n -> n `elemNameSet` ns
sigName :: LSig name -> Maybe name
sigName (L _ sig) = f sig
where
f (TypeSig n _) = Just (unLoc n)
f (SpecSig n _ _) = Just (unLoc n)
f (InlineSig n _) = Just (unLoc n)
f (FixSig (FixitySig n _)) = Just (unLoc n)
f other = Nothing
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> Maybe name
sigNameNoLoc (TypeSig n _) = Just (unLoc n)
sigNameNoLoc (SpecSig n _ _) = Just (unLoc n)
sigNameNoLoc (InlineSig n _) = Just (unLoc n)
sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
sigNameNoLoc other = Nothing
isFixityLSig :: LSig name -> Bool
isFixityLSig (L _ (FixSig {})) = True
......
compiler/hsSyn/HsDecls.lhs
View file @ 190f2489
......@@ -15,6 +15,7 @@ module HsDecls (
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), ResType(..), LConDecl,
DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..),
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
......@@ -35,9 +36,10 @@ import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds,
Sig(..), LSig, LFixitySig, pprLHsBinds,
emptyValBindsIn, emptyValBindsOut )
import HsPat ( HsConDetails(..), hsConArgs )
import HsPat ( HsConDetails(..), hsConArgs, HsRecField(..) )
import HsImpExp ( pprHsVar )
import HsTypes
import HsDoc ( HsDoc, LHsDoc, ppr_mbDoc )
import NameSet ( NameSet )
import CoreSyn ( RuleName )
import {- Kind parts of -} Type ( Kind, pprKind )
......@@ -54,7 +56,6 @@ import FastString
import Maybe ( isJust )
\end{code}
%************************************************************************
%* *
\subsection[HsDecl]{Declarations}
......@@ -75,6 +76,8 @@ data HsDecl id
| DeprecD (DeprecDecl id)
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
| DocD (DocDecl id)
-- NB: all top-level fixity decls are contained EITHER
-- EITHER SigDs
......@@ -105,7 +108,11 @@ data HsGroup id
hs_defds :: [LDefaultDecl id],
hs_fords :: [LForeignDecl id],
hs_depds :: [LDeprecDecl id],
hs_ruleds :: [LRuleDecl id]
hs_ruleds :: [LRuleDecl id],
hs_docs :: [DocEntity id]
-- Used to remember the module structure,
-- which is needed to produce Haddock documentation
}
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
......@@ -115,7 +122,8 @@ emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_fords = [],
hs_depds = [], hs_ruleds = [],
hs_valds = error "emptyGroup hs_valds: Can't happen" }
hs_valds = error "emptyGroup hs_valds: Can't happen",
hs_docs = [] }
appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
appendGroups
......@@ -128,7 +136,8 @@ appendGroups
hs_defds = defds1,
hs_fords = fords1,
hs_depds = depds1,
hs_ruleds = rulds1 }
hs_ruleds = rulds1,
hs_docs = docs1 }
HsGroup {
hs_valds = val_groups2,
hs_tyclds = tyclds2,
......@@ -138,7 +147,8 @@ appendGroups
hs_defds = defds2,
hs_fords = fords2,
hs_depds = depds2,
hs_ruleds = rulds2 }
hs_ruleds = rulds2,
hs_docs = docs2 }
=
HsGroup {
hs_valds = val_groups1 `plusHsValBinds` val_groups2,
......@@ -149,21 +159,23 @@ appendGroups
hs_defds = defds1 ++ defds2,
hs_fords = fords1 ++ fords2,
hs_depds = depds1 ++ depds2,
hs_ruleds = rulds1 ++ rulds2 }
hs_ruleds = rulds1 ++ rulds2,
hs_docs = docs1 ++ docs2 }
\end{code}
\begin{code}
instance OutputableBndr name => Outputable (HsDecl name) where
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
ppr (DerivD deriv) = ppr deriv
ppr (ForD fd) = ppr fd
ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
ppr (SpliceD dd) = ppr dd
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
ppr (DerivD deriv) = ppr deriv
ppr (ForD fd) = ppr fd
ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
ppr (SpliceD dd) = ppr dd
ppr (DocD doc) = ppr doc
instance OutputableBndr name => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls,
......@@ -414,10 +426,11 @@ data TyClDecl name
tcdFDs :: [Located (FunDep name)], -- Functional deps
tcdSigs :: [LSig name], -- Methods' signatures
tcdMeths :: LHsBinds name, -- Default methods
tcdATs :: [LTyClDecl name] -- Associated types; ie
tcdATs :: [LTyClDecl name], -- Associated types; ie
-- only 'TyData',
-- 'TyFunction',
-- and 'TySynonym'
tcdDocs :: [DocEntity name] -- Haddock docs
}
data NewOrData
......@@ -638,6 +651,8 @@ data ConDecl name
, con_details :: HsConDetails name (LBangType name) -- The main payload
, con_res :: ResType name -- Result type of the constructor
, con_doc :: Maybe (LHsDoc name) -- A possible Haddock comment
}
data ResType name
......@@ -657,7 +672,7 @@ conDeclsNames cons
do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
= (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc)
where
new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ]
new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ]
do_one (flds_seen, acc) c
= (flds_seen, (con_name c):acc)
......@@ -670,23 +685,23 @@ conDetailsTys details = map getBangType (hsConArgs details)
instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl (ConDecl con expl tvs cxt details ResTyH98)
= sep [pprHsForAll expl tvs cxt, ppr_details con details]
pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields
pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty))
pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
= ppr con <+> dcolon <+>
sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
where
mk_fun_ty a b = noLoc (HsFunTy a b)
pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty))
= sep [pprHsForAll expl tvs cxt, ppr con <+> ppr fields <+> dcolon <+> ppr res_ty]
ppr_fields fields = braces (sep (punctuate comma (map ppr_field fields)))
ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
= sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
ppr_fields fields = braces (sep (punctuate comma (map ppr fields)))
\end{code}
%************************************************************************
......@@ -909,6 +924,37 @@ instance OutputableBndr name => Outputable (RuleBndr name) where
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
\end{code}
%************************************************************************
%* *
\subsection[DocDecl]{Document comments}
%* *
%************************************************************************
\begin{code}
-- source code entities, for representing the module structure
data DocEntity name
= DeclEntity name
| DocEntity (DocDecl name)
type LDocDecl name = Located (DocDecl name)
data DocDecl name
= DocCommentNext (HsDoc name)
| DocCommentPrev (HsDoc name)
| DocCommentNamed String (HsDoc name)
| DocGroup Int (HsDoc name)
-- Okay, I need to reconstruct the document comments, but for now:
instance Outputable (DocDecl name) where
ppr _ = text "<document comment>"
docDeclDoc (DocCommentNext d) = d
docDeclDoc (DocCommentPrev d) = d
docDeclDoc (DocCommentNamed _ d) = d
docDeclDoc (DocGroup _ d) = d
\end{code}
%************************************************************************
%* *
......
compiler/hsSyn/HsDoc.hs 0 → 100644
View file @ 190f2489
module HsDoc (
HsDoc(..),
LHsDoc,
docAppend,
docParagraph,
ppr_mbDoc
) where
#include "HsVersions.h"
import RdrName
import Outputable
import SrcLoc
import Data.Char (isSpace)
data HsDoc id
= DocEmpty
| DocAppend (HsDoc id) (HsDoc id)
| DocString String
| DocParagraph (HsDoc id)
| DocIdentifier [id]
| DocModule String
| DocEmphasis (HsDoc id)
| DocMonospaced (HsDoc id)
| DocUnorderedList [HsDoc id]
| DocOrderedList [HsDoc id]
| DocDefList [(HsDoc id, HsDoc id)]
| DocCodeBlock (HsDoc id)
| DocURL String
| DocAName String
deriving (Eq, Show)
type LHsDoc a = Located (HsDoc a)
instance Outputable (HsDoc a) where
ppr _ = text "<document comment>"
ppr_mbDoc (Just doc) = ppr doc
ppr_mbDoc Nothing = empty
-- used to make parsing easier; we group the list items later
docAppend :: HsDoc id -> HsDoc id -> HsDoc id
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
= DocUnorderedList (ds1++ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
= DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2)
= DocOrderedList (ds1++ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
= DocAppend (DocOrderedList (ds1++ds2)) d
docAppend (DocDefList ds1) (DocDefList ds2)
= DocDefList (ds1++ds2)
docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
= DocAppend (DocDefList (ds1++ds2)) d
docAppend DocEmpty d = d
docAppend d DocEmpty = d
docAppend d1 d2
= DocAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph :: HsDoc id -> HsDoc id
docParagraph (DocMonospaced p)
= DocCodeBlock p
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
| all isSpace s1
= DocCodeBlock p
docParagraph (DocAppend (DocString s1)
(DocAppend (DocMonospaced p) (DocString s2)))
| all isSpace s1 && all isSpace s2
= DocCodeBlock p
docParagraph (DocAppend (DocMonospaced p) (DocString s2))
| all isSpace s2
= DocCodeBlock p
docParagraph p
= DocParagraph p
compiler/hsSyn/HsImpExp.lhs
View file @ 190f2489
......@@ -9,6 +9,8 @@ module HsImpExp where
#include "HsVersions.h"
import Module ( ModuleName )
import HsDoc ( HsDoc )
import Outputable
import FastString
import SrcLoc ( Located(..) )
......@@ -68,11 +70,14 @@ ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm
type LIE name = Located (IE name)
data IE name
= IEVar name
| IEThingAbs name -- Class/Type (can't tell)
| IEThingAll name -- Class/Type plus all methods/constructors
| IEThingWith name [name] -- Class/Type plus some methods/constructors
| IEModuleContents ModuleName -- (Export Only)
= IEVar name
| IEThingAbs name -- Class/Type (can't tell)
| IEThingAll name -- Class/Type plus all methods/constructors
| IEThingWith name [name] -- Class/Type plus some methods/constructors
| IEModuleContents ModuleName -- (Export Only)
| IEGroup Int (HsDoc name) -- Doc section heading
| IEDoc (HsDoc name) -- Some documentation
| IEDocNamed String -- Reference to named doc
\end{code}
\begin{code}
......@@ -88,6 +93,9 @@ ieNames (IEThingAbs n ) = [n]
ieNames (IEThingAll n ) = [n]
ieNames (IEThingWith n ns) = n:ns
ieNames (IEModuleContents _ ) = []
ieNames (IEGroup _ _ ) = []
ieNames (IEDoc _ ) = []
ieNames (IEDocNamed _ ) = []
\end{code}
\begin{code}
......@@ -99,6 +107,9 @@ instance (Outputable name) => Outputable (IE name) where
= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
ppr (IEModuleContents mod)
= ptext SLIT("module") <+> ppr mod
ppr (IEGroup n doc) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
\end{code}
\begin{code}
......
compiler/hsSyn/HsPat.lhs
View file @ 190f2489
......@@ -8,6 +8,7 @@ module HsPat (
Pat(..), InPat, OutPat, LPat,
HsConDetails(..), hsConArgs,
HsRecField(..), mkRecField,
mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
......@@ -26,6 +27,7 @@ import HsBinds ( DictBinds, HsBind(..), HsWrapper, isIdHsWrapper, pprHsWrapper,
emptyLHsBinds, pprLHsBinds )
import HsLit ( HsLit(HsCharPrim), HsOverLit )
import HsTypes ( LHsType, PostTcType )
import HsDoc ( LHsDoc, ppr_mbDoc )
import BasicTypes ( Boxity, tupleParens )
-- others:
import PprCore ( {- instance OutputableBndr TyVar -} )
......@@ -138,13 +140,21 @@ HsConDetails is use both for patterns and for data type declarations
\begin{code}
data HsConDetails id arg
= PrefixCon [arg] -- C p1 p2 p3
| RecCon [(Located id, arg)] -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
= PrefixCon [arg] -- C p1 p2 p3
| RecCon [HsRecField id arg] -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
data HsRecField id arg = HsRecField {
hsRecFieldId :: Located id,
hsRecFieldArg :: arg,
hsRecFieldDoc :: Maybe (LHsDoc id)
}
mkRecField id arg = HsRecField id arg Nothing
hsConArgs :: HsConDetails id arg -> [arg]
hsConArgs (PrefixCon ps) = ps
hsConArgs (RecCon fs) = map snd fs
hsConArgs (RecCon fs) = map hsRecFieldArg fs
hsConArgs (InfixCon p1 p2) = [p1,p2]
\end{code}
......@@ -209,13 +219,17 @@ pprConArgs (PrefixCon pats) = interppSP pats
pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats)))
where
pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
pp_rpat (HsRecField v p d) =
hsep [ppr d, ppr v, char '=', ppr p]
-- add parallel array brackets around a document
--
pabrackets :: SDoc -> SDoc
pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
instance (OutputableBndr id, Outputable arg) =>
Outputable (HsRecField id arg) where
ppr (HsRecField n ty doc) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
......
compiler/hsSyn/HsSyn.lhs
View file @ 190f2489
......@@ -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