Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
190f2489
Commit
190f2489
authored
Oct 05, 2006
by
davve@dtek.chalmers.se
Browse files
Merge Haddock comment support from ghc.haddock -- big patch
parent
aa8e9422
Changes
40
Hide whitespace changes
Inline
Side-by-side
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,