Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,265
Issues
4,265
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
421
Merge Requests
421
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
190f2489
Commit
190f2489
authored
Oct 05, 2006
by
davve@dtek.chalmers.se
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Merge Haddock comment support from ghc.haddock -- big patch
parent
aa8e9422
Changes
40
Hide whitespace changes
Inline
Side-by-side
Showing
40 changed files
with
1467 additions
and
280 deletions
+1467
-280
compiler/cmm/CmmLex.x
compiler/cmm/CmmLex.x
+2
-2
compiler/deSugar/Check.lhs
compiler/deSugar/Check.lhs
+2
-2
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMeta.hs
+7
-7
compiler/deSugar/MatchCon.lhs
compiler/deSugar/MatchCon.lhs
+2
-2
compiler/hsSyn/Convert.lhs
compiler/hsSyn/Convert.lhs
+9
-9
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsBinds.lhs
+8
-7
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsDecls.lhs
+72
-26
compiler/hsSyn/HsDoc.hs
compiler/hsSyn/HsDoc.hs
+77
-0
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsImpExp.lhs
+16
-5
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsPat.lhs
+20
-6
compiler/hsSyn/HsSyn.lhs
compiler/hsSyn/HsSyn.lhs
+37
-6
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsTypes.lhs
+6
-0
compiler/hsSyn/HsUtils.lhs
compiler/hsSyn/HsUtils.lhs
+19
-0
compiler/main/DynFlags.hs
compiler/main/DynFlags.hs
+7
-4
compiler/main/GHC.hs
compiler/main/GHC.hs
+14
-2
compiler/main/HeaderInfo.hs
compiler/main/HeaderInfo.hs
+1
-1
compiler/main/HscMain.lhs
compiler/main/HscMain.lhs
+9
-4
compiler/main/HscStats.lhs
compiler/main/HscStats.lhs
+1
-1
compiler/package.conf.in
compiler/package.conf.in
+3
-0
compiler/parser/HaddockLex.hs-boot
compiler/parser/HaddockLex.hs-boot
+18
-0
compiler/parser/HaddockLex.x
compiler/parser/HaddockLex.x
+161
-0
compiler/parser/HaddockParse.y
compiler/parser/HaddockParse.y
+98
-0
compiler/parser/HaddockUtils.hs
compiler/parser/HaddockUtils.hs
+184
-0
compiler/parser/Lexer.x
compiler/parser/Lexer.x
+230
-60
compiler/parser/Parser.y.pp
compiler/parser/Parser.y.pp
+176
-50
compiler/parser/ParserCore.y
compiler/parser/ParserCore.y
+3
-3
compiler/parser/RdrHsSyn.lhs
compiler/parser/RdrHsSyn.lhs
+57
-34
compiler/rename/RnEnv.lhs
compiler/rename/RnEnv.lhs
+1
-0
compiler/rename/RnHsDoc.hs
compiler/rename/RnHsDoc.hs
+88
-0
compiler/rename/RnHsSyn.lhs
compiler/rename/RnHsSyn.lhs
+2
-1
compiler/rename/RnNames.lhs
compiler/rename/RnNames.lhs
+28
-2
compiler/rename/RnSource.lhs
compiler/rename/RnSource.lhs
+46
-14
compiler/rename/RnTypes.lhs
compiler/rename/RnTypes.lhs
+12
-5
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsSyn.lhs
+6
-6
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcHsType.lhs
+4
-0
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcPat.lhs
+7
-5
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnDriver.lhs
+16
-4
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnMonad.lhs
+4
-2
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRnTypes.lhs
+5
-2
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyClsDecls.lhs
+9
-8
No files found.
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, ppr
HsForAll 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