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
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
-- -----------------------------------------------------------------------------
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
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)]
-------------------------------------------------------
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']
= 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' }
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
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 )
-- 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}
= 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)
= 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')
; 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' }
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
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
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
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), ResType(..), LConDecl,
+ DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..),
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
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 )
import Maybe ( isJust )
\end{code}
-
%************************************************************************
%* *
\subsection[HsDecl]{Declarations}
| DeprecD (DeprecDecl id)
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
+ | DocD (DocDecl id)
+
-- NB: all top-level fixity decls are contained EITHER
-- EITHER SigDs
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
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
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,
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,
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,
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
, 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
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)
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}
%************************************************************************
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}
%************************************************************************
%* *
--- /dev/null
+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
#include "HsVersions.h"
import Module ( ModuleName )
+import HsDoc ( HsDoc )
+
import Outputable
import FastString
import SrcLoc ( Located(..) )
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}
ieNames (IEThingAll n ) = [n]
ieNames (IEThingWith n ns) = n:ns
ieNames (IEModuleContents _ ) = []
+ieNames (IEGroup _ _ ) = []
+ieNames (IEDoc _ ) = []
+ieNames (IEDocNamed _ ) = []
\end{code}
\begin{code}
= 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}
Pat(..), InPat, OutPat, LPat,
HsConDetails(..), hsConArgs,
+ HsRecField(..), mkRecField,
mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
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 -} )
\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}
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}
module HsPat,
module HsTypes,
module HsUtils,
+ module HsDoc,
Fixity,
- HsModule(..), HsExtCore(..)
- ) where
+ HsModule(..), HsExtCore(..),
+
+ HaddockModInfo(..),
+ emptyHaddockModInfo,
+) where
#include "HsVersions.h"
import HsTypes
import BasicTypes ( Fixity, DeprecTxt )
import HsUtils
+import HsDoc
-- others:
import IfaceSyn ( IfaceBinding )
-- 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
[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 [
],
pp_nonnull imports,
pp_nonnull decls
- ]
+ ]
where
pp_header rest = case deprec of
Nothing -> pp_modname <+> rest
pp_modname = ptext SLIT("module") <+> ppr name
+pp_mb (Just x) = ppr x
+pp_mb Nothing = empty
+
pp_nonnull [] = empty
pp_nonnull xs = vcat (map ppr xs)
\end{code}
import {- Kind parts of -}
Type ( {- instance Outputable Kind -} Kind,
pprParendKind, pprKind, isLiftedTypeKind )
+import HsDoc ( LHsDoc, HsDoc )
import BasicTypes ( IPName, Boxity, tupleParens )
import SrcLoc ( Located(..), unLoc, noSrcSpan )
import StaticFlags ( opt_PprStyle_Debug )
| HsSpliceTy (HsSplice name)
+ | HsDocTy (LHsType name) (LHsDoc name) -- A documented type
+
data HsExplicitForAll = Explicit | Implicit
-----------------------
-- But we still use the precedence stuff to add parens because
-- toHsType doesn't put in any HsParTys, so we may still need them
+ppr_mono_ty ctxt_prec (HsDocTy ty doc)
+ = ppr ty <+> ppr (unLoc doc)
+
--------------------------
ppr_fun_ty ctxt_prec ty1 ty2
= let p1 = ppr_mono_lty pREC_FUN ty1
import HsPat
import HsTypes
import HsLit
+import HsDecls
import RdrName ( RdrName, getRdrName, mkRdrUnqual )
import Var ( Id )
collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
+
+%************************************************************************
+%* *
+%* Getting the main binder name of a top declaration
+%* *
+%************************************************************************
+
+\begin{code}
+
+getMainDeclBinder :: HsDecl name -> Maybe name
+getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder (ValD d) = Just ((unLoc . head) (collectAcc d []))
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
+getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
+getMainDeclBinder _ = Nothing
+
+\end{code}
getVerbFlag,
updOptLevel,
setTmpDir,
+ setPackageName,
-- parsing DynFlags
parseDynamicFlags,
allFlags,
-- misc stuff
- machdepCCOpts, picCCOpts,
+ machdepCCOpts, picCCOpts
) where
#include "HsVersions.h"
| Opt_StgStats
| Opt_HideAllPackages
| Opt_PrintBindResult
+ | Opt_Haddock
-- keeping stuff
| Opt_KeepHiDiffs
, ( "F" , NoArg (setDynFlag Opt_Pp))
, ( "#include" , HasArg (addCmdlineHCInclude) )
, ( "v" , OptIntSuffix setVerbosity )
-
------- Specific phases --------------------------------------------
, ( "pgmL" , HasArg (upd . setPgmL) )
, ( "pgmP" , HasArg (upd . setPgmP) )
------- Miscellaneous ----------------------------------------------
, ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain))
, ( "main-is" , SepArg setMainIs )
+ , ( "haddock" , NoArg (setDynFlag Opt_Haddock) )
------- recompilation checker (DEPRECATED, use -fforce-recomp) -----
, ( "recomp" , NoArg (unSetDynFlag Opt_ForceRecomp) )
------- Packages ----------------------------------------------------
, ( "package-conf" , HasArg extraPkgConf_ )
, ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) )
- , ( "package-name" , HasArg setPackageName )
+ , ( "package-name" , HasArg (upd . setPackageName) )
, ( "package" , HasArg exposePackage )
, ( "hide-package" , HasArg hidePackage )
, ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) )
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
+
setPackageName p
| Nothing <- unpackPackageId pid
= throwDyn (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier"))
| otherwise
- = upd (\s -> s{ thisPackage = pid })
+ = \s -> s{ thisPackage = pid }
where
pid = stringToPackageId p
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
+ -- * Parsing Haddock comments
+ parseHaddockComment,
+
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
globalRdrEnvElts, extendGlobalRdrEnv,
emptyGlobalRdrEnv )
-import HsSyn
+import HsSyn
import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
pprThetaArrow, pprParendType, splitForAllTys,
funResultTy )
import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
+import HaddockParse ( parseHaddockParagraphs, parseHaddockString )
+import HaddockLex ( tokenise )
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids }
-- -----------------------------------------------------------------------------
+-- Parsing Haddock comments
+
+parseHaddockComment :: String -> Either String (HsDoc RdrName)
+parseHaddockComment string = parseHaddockParagraphs (tokenise string)
+
+-- -----------------------------------------------------------------------------
-- Loading the program
-- Perform a dependency analysis starting from the current targets
-- fields within CheckedModule.
type ParsedSource = Located (HsModule RdrName)
-type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
+type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+ Maybe (HsDoc Name), HaddockModInfo Name)
type TypecheckedSource = LHsBinds Id
-- NOTE:
PFailed span err -> parseError span err
POk _ rdr_module ->
case rdr_module of
- L _ (HsModule mod _ imps _ _) ->
+ L _ (HsModule mod _ imps _ _ _ _ _) ->
let
mod_name | Just located_mod <- mod = located_mod
| otherwise = L noSrcSpan mAIN_NAME
#include "HsVersions.h"
#ifdef GHCI
-import HsSyn ( Stmt(..), LStmt, LHsType )
+import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType )
+import Module ( Module )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import Var ( Id )
import Module ( emptyModuleEnv, ModLocation(..) )
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
-import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl )
+import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
+ HaddockModInfo )
import SrcLoc ( Located(..) )
import StringBuffer ( hGetStringBuffer, stringToStringBuffer )
import Parser
-- parsed
(Located (HsModule RdrName))
-- renamed
- (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name]))
+ (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+ Maybe (HsDoc Name), HaddockModInfo Name))
-- typechecked
(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
rnInfo = do decl <- tcg_rn_decls tc_result
imports <- tcg_rn_imports tc_result
let exports = tcg_rn_exports tc_result
- return (decl,imports,exports)
+ let doc = tcg_doc tc_result
+ hmi = tcg_hmi tc_result
+ return (decl,imports,exports,doc,hmi)
return (Just (HscChecked rdr_module
rnInfo
(Just (tcg_binds tc_result,
%************************************************************************
\begin{code}
-ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
HsSyn
HsTypes
HsUtils
+ HsDoc
HscMain
HscStats
HscTypes
VarSet
WorkWrap
WwLib
+ HaddockParse
+ HaddockLex
#ifdef INSTALLING
import-dirs: PKG_LIBDIR"/hslibs-imports/ghc"
--- /dev/null
+module HaddockLex ( Token(..), tokenise ) where
+
+import RdrName
+
+tokenise :: String -> [Token]
+
+data Token
+ = TokPara
+ | TokNumber
+ | TokBullet
+ | TokDefStart
+ | TokDefEnd
+ | TokSpecial Char
+ | TokIdent [RdrName]
+ | TokString String
+ | TokURL String
+ | TokAName String
+ | TokBirdTrack String
--- /dev/null
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+-- This file was modified and integrated into GHC by David Waern 2006
+--
+
+{
+module HaddockLex (
+ Token(..),
+ tokenise
+ ) where
+
+import HsSyn
+import Lexer hiding (Token)
+import Parser ( parseIdentifier )
+import StringBuffer
+import OccName
+import RdrName
+import SrcLoc
+import DynFlags
+import DynFlags
+
+import Char
+import Numeric
+import System.IO.Unsafe
+}
+
+$ws = $white # \n
+$digit = [0-9]
+$hexdigit = [0-9a-fA-F]
+$special = [\"\@\/]
+$alphanum = [A-Za-z0-9]
+$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
+
+:-
+
+-- beginning of a paragraph
+<0,para> {
+ $ws* \n ;
+ $ws* \> { begin birdtrack }
+ $ws* [\*\-] { token TokBullet `andBegin` string }
+ $ws* \[ { token TokDefStart `andBegin` def }
+ $ws* \( $digit+ \) { token TokNumber `andBegin` string }
+ $ws* { begin string }
+}
+
+-- beginning of a line
+<line> {
+ $ws* \> { begin birdtrack }
+ $ws* \n { token TokPara `andBegin` para }
+ -- Here, we really want to be able to say
+ -- $ws* (\n | <eof>) { token TokPara `andBegin` para}
+ -- because otherwise a trailing line of whitespace will result in
+ -- a spurious TokString at the end of a docstring. We don't have <eof>,
+ -- though (NOW I realise what it was for :-). To get around this, we always
+ -- append \n to the end of a docstring.
+ () { begin string }
+}
+
+<birdtrack> .* \n? { strtoken TokBirdTrack `andBegin` line }
+
+<string,def> {
+ $special { strtoken $ \s -> TokSpecial (head s) }
+ \<.*\> { strtoken $ \s -> TokURL (init (tail s)) }
+ \#.*\# { strtoken $ \s -> TokAName (init (tail s)) }
+ [\'\`] $ident+ [\'\`] { ident }
+ \\ . { strtoken (TokString . tail) }
+ "&#" $digit+ \; { strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
+ "&#" [xX] $hexdigit+ \; { strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
+ -- allow special characters through if they don't fit one of the previous
+ -- patterns.
+ [\'\`\<\#\&\\] { strtoken TokString }
+ [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }
+ [^ $special \< \# \n \'\` \& \\ \]]+ { strtoken TokString }
+}
+
+<def> {
+ \] { token TokDefEnd `andBegin` string }
+}
+
+-- ']' doesn't have any special meaning outside of the [...] at the beginning
+-- of a definition paragraph.
+<string> {
+ \] { strtoken TokString }
+}
+
+{
+data Token
+ = TokPara
+ | TokNumber
+ | TokBullet
+ | TokDefStart
+ | TokDefEnd
+ | TokSpecial Char
+ | TokIdent [RdrName]
+ | TokString String
+ | TokURL String
+ | TokAName String
+ | TokBirdTrack String
+-- deriving Show
+
+-- -----------------------------------------------------------------------------
+-- Alex support stuff
+
+type StartCode = Int
+type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
+
+type AlexInput = (Char,String)
+
+alexGetChar (_, []) = Nothing
+alexGetChar (_, c:cs) = Just (c, (c,cs))
+
+alexInputPrevChar (c,_) = c
+
+tokenise :: String -> [Token]
+tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
+ where go inp@(_,str) sc =
+ case alexScan inp sc of
+ AlexEOF -> []
+ AlexError _ -> error "lexical error"
+ AlexSkip inp' len -> go inp' sc
+ AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
+
+-- NB. we add a final \n to the string, (see comment in the beginning of line
+-- production above).
+eofHack str = str++"\n"
+
+andBegin :: Action -> StartCode -> Action
+andBegin act new_sc = \str sc cont -> act str new_sc cont
+
+token :: Token -> Action
+token t = \str sc cont -> t : cont sc
+
+strtoken :: (String -> Token) -> Action
+strtoken t = \str sc cont -> t str : cont sc
+
+begin :: StartCode -> Action
+begin sc = \str _ cont -> cont sc
+
+-- -----------------------------------------------------------------------------
+-- Lex a string as a Haskell identifier
+
+ident :: Action
+ident str sc cont =
+ case strToHsQNames id of
+ Just names -> TokIdent names : cont sc
+ Nothing -> TokString str : cont sc
+ where id = init (tail str)
+
+strToHsQNames :: String -> Maybe [RdrName]
+strToHsQNames str0 =
+ let buffer = unsafePerformIO (stringToStringBuffer str0)
+ pstate = mkPState buffer noSrcLoc defaultDynFlags
+ lex = lexer (\t -> return t)
+ result = unP parseIdentifier pstate
+ in case result of
+ POk _ name -> Just [unLoc name]
+ _ -> Nothing
+}
--- /dev/null
+{
+module HaddockParse (parseHaddockParagraphs, parseHaddockString) where
+
+import {-# SOURCE #-} HaddockLex
+import HsSyn
+import RdrName
+}
+
+%tokentype { Token }
+
+%token '/' { TokSpecial '/' }
+ '@' { TokSpecial '@' }
+ '[' { TokDefStart }
+ ']' { TokDefEnd }
+ DQUO { TokSpecial '\"' }
+ URL { TokURL $$ }
+ ANAME { TokAName $$ }
+ '-' { TokBullet }
+ '(n)' { TokNumber }
+ '>..' { TokBirdTrack $$ }
+ IDENT { TokIdent $$ }
+ PARA { TokPara }
+ STRING { TokString $$ }
+
+%monad { Either String }
+
+%name parseHaddockParagraphs doc
+%name parseHaddockString seq
+
+%%
+
+doc :: { HsDoc RdrName }
+ : apara PARA doc { docAppend $1 $3 }
+ | PARA doc { $2 }
+ | apara { $1 }
+ | {- empty -} { DocEmpty }
+
+apara :: { HsDoc RdrName }
+ : ulpara { DocUnorderedList [$1] }
+ | olpara { DocOrderedList [$1] }
+ | defpara { DocDefList [$1] }
+ | para { $1 }
+
+ulpara :: { HsDoc RdrName }
+ : '-' para { $2 }
+
+olpara :: { HsDoc RdrName }
+ : '(n)' para { $2 }
+
+defpara :: { (HsDoc RdrName, HsDoc RdrName) }
+ : '[' seq ']' seq { ($2, $4) }
+
+para :: { HsDoc RdrName }
+ : seq { docParagraph $1 }
+ | codepara { DocCodeBlock $1 }
+
+codepara :: { HsDoc RdrName }
+ : '>..' codepara { docAppend (DocString $1) $2 }
+ | '>..' { DocString $1 }
+
+seq :: { HsDoc RdrName }
+ : elem seq { docAppend $1 $2 }
+ | elem { $1 }
+
+elem :: { HsDoc RdrName }
+ : elem1 { $1 }
+ | '@' seq1 '@' { DocMonospaced $2 }
+
+seq1 :: { HsDoc RdrName }
+ : elem1 seq1 { docAppend $1 $2 }
+ | elem1 { $1 }
+
+elem1 :: { HsDoc RdrName }
+ : STRING { DocString $1 }
+ | '/' strings '/' { DocEmphasis (DocString $2) }
+ | URL { DocURL $1 }
+ | ANAME { DocAName $1 }
+ | IDENT { DocIdentifier $1 }
+ | DQUO strings DQUO { DocModule $2 }
+
+strings :: { String }
+ : STRING { $1 }
+ | STRING strings { $1 ++ $2 }
+
+{
+happyError :: [Token] -> Either String a
+happyError toks =
+-- Left ("parse error in doc string: " ++ show (take 3 toks))
+ Left ("parse error in doc string")
+
+-- Either monad (we can't use MonadError because GHC < 5.00 has
+-- an older incompatible version).
+instance Monad (Either String) where
+ return = Right
+ Left l >>= _ = Left l
+ Right r >>= k = k r
+ fail msg = Left msg
+}
--- /dev/null
+module HaddockUtils where
+
+import HsSyn
+import HsDoc
+import {-# SOURCE #-} HaddockLex
+import HaddockParse
+import SrcLoc
+import RdrName
+
+import Control.Monad
+import Data.Maybe
+import Data.Char
+import Data.Either
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+-- NB. The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: String -> Either String (String, HaddockModInfo RdrName)
+parseModuleHeader str0 =
+ let
+ getKey :: String -> String -> (Maybe String,String)
+ getKey key str = case parseKey key str of
+ Nothing -> (Nothing,str)
+ Just (value,rest) -> (Just value,rest)
+
+ (moduleOpt,str1) = getKey "Module" str0
+ (descriptionOpt,str2) = getKey "Description" str1
+ (copyrightOpt,str3) = getKey "Copyright" str2
+ (licenseOpt,str4) = getKey "License" str3
+ (licenceOpt,str5) = getKey "Licence" str4
+ (maintainerOpt,str6) = getKey "Maintainer" str5
+ (stabilityOpt,str7) = getKey "Stability" str6
+ (portabilityOpt,str8) = getKey "Portability" str7
+
+ description1 :: Either String (Maybe (HsDoc RdrName))
+ description1 = case descriptionOpt of
+ Nothing -> Right Nothing
+ Just description -> case parseHaddockString . tokenise $ description of
+
+ Left mess -> Left ("Cannot parse Description: " ++ mess)
+ Right doc -> Right (Just doc)
+ in
+ case description1 of
+ Left mess -> Left mess
+ Right docOpt -> Right (str8,HaddockModInfo {
+ hmi_description = docOpt,
+ hmi_portability = portabilityOpt,
+ hmi_stability = stabilityOpt,
+ hmi_maintainer = maintainerOpt
+ })
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":"
+-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- > rather long
+-- >
+-- > description
+-- >
+-- > The module comment starts here
+--
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+ do
+ let
+ (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+ indentation = spaces0
+ afterKey0 <- extractPrefix key toParse1
+ let
+ afterKey1 = extractLeadingSpaces afterKey0
+ afterColon0 <- case snd afterKey1 of
+ ':':afterColon -> return afterColon
+ _ -> Nothing
+ let
+ (_,afterColon1) = extractLeadingSpaces afterColon0
+
+ return (scanKey True indentation afterColon1)
+ where
+ scanKey :: Bool -> String -> String -> (String,String)
+ scanKey isFirst indentation [] = ([],[])
+ scanKey isFirst indentation str =
+ let
+ (nextLine,rest1) = extractNextLine str
+
+ accept = isFirst || sufficientIndentation || allSpaces
+
+ sufficientIndentation = case extractPrefix indentation nextLine of
+ Just (c:_) | isSpace c -> True
+ _ -> False
+
+ allSpaces = case extractLeadingSpaces nextLine of
+ (_,[]) -> True
+ _ -> False
+ in
+ if accept
+ then
+ let
+ (scanned1,rest2) = scanKey False indentation rest1
+
+ scanned2 = case scanned1 of
+ "" -> if allSpaces then "" else nextLine
+ _ -> nextLine ++ "\n" ++ scanned1
+ in
+ (scanned2,rest2)
+ else
+ ([],str)
+
+ extractLeadingSpaces :: String -> (String,String)
+ extractLeadingSpaces [] = ([],[])
+ extractLeadingSpaces (s@(c:cs))
+ | isSpace c =
+ let
+ (spaces1,cs1) = extractLeadingSpaces cs
+ in
+ (c:spaces1,cs1)
+ | True = ([],s)
+
+ extractNextLine :: String -> (String,String)
+ extractNextLine [] = ([],[])
+ extractNextLine (c:cs)
+ | c == '\n' =
+ ([],cs)
+ | True =
+ let
+ (line,rest) = extractNextLine cs
+ in
+ (c:line,rest)
+
+
+ -- indentation returns characters after last newline.
+ indentation :: String -> String
+ indentation s = fromMaybe s (indentation0 s)
+ where
+ indentation0 :: String -> Maybe String
+ indentation0 [] = Nothing
+ indentation0 (c:cs) =
+ case indentation0 cs of
+ Nothing -> if c == '\n' then Just cs else Nothing
+ in0 -> in0
+
+ -- comparison is case-insensitive.
+ extractPrefix :: String -> String -> Maybe String
+ extractPrefix [] s = Just s
+ extractPrefix s [] = Nothing
+ extractPrefix (c1:cs1) (c2:cs2)
+ | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+ | True = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Adding documentation to record fields (used in parsing).
+
+type Field a = ([Located a], LBangType a, Maybe (LHsDoc a))
+
+addFieldDoc :: Field a -> Maybe (LHsDoc a) -> Field a
+addFieldDoc (a, b, c) doc = (a, b, c `mplus` doc)
+
+addFieldDocs :: [Field a] -> Maybe (LHsDoc a) -> [Field a]
+addFieldDocs [] _ = []
+addFieldDocs (x:xs) doc = addFieldDoc x doc : xs
+
+addConDoc :: LConDecl a -> Maybe (LHsDoc a) -> LConDecl a
+addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } )
+
+addConDocs :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocs [] _ = []
+addConDocs [x] doc = [addConDoc x doc]
+addConDocs (x:xs) doc = x : addConDocs xs doc
+
+addConDocFirst :: [LConDecl a] -> Maybe (LHsDoc a) -> [LConDecl a]
+addConDocFirst [] _ = []
+addConDocFirst (x:xs) doc = addConDoc x doc : xs
import Util ( maybePrefixMatch, readRational )
import DATA_BITS
-import Data.Char ( chr )
+import Data.Char ( chr, isSpace )
import Ratio
---import TRACE
+import TRACE
#if __GLASGOW_HASKELL__ >= 605
import Data.Char ( GeneralCategory(..), generalCategory, isPrint, isUpper )
$nl = [\n\r]
$idchar = [$small $large $digit \']
+$docsym = [\| \^ \* \$]
+
@varid = $small $idchar*
@conid = $large $idchar*
-- pragmas, "{-#", so that we don't accidentally treat them as comments.
-- (this can happen even though pragmas will normally take precedence due to
-- longest-match, because pragmas aren't valid in every state, but comments
--- are).
-"{-" / { notFollowedBy '#' } { nested_comment }
+-- are). We also rule out nested Haddock comments, if the -haddock flag is
+-- set.
+
+"{-" / { isNormalComment } { nested_comment lexToken }
-- Single-line comments are a bit tricky. Haskell 98 says that two or
-- more dashes followed by a symbol should be parsed as a varsym, so we
-- have to exclude those.
--- The regex says: "munch all the characters after the dashes, as long as
--- the first one is not a symbol".
-"--"\-* [^$symbol :] .* ;
-"--"\-* / { atEOL } ;
+
+-- Since Haddock comments aren't valid in every state, we need to rule them
+-- out here.
+
+-- The following two rules match comments that begin with two dashes, but
+-- continue with a different character. The rules test that this character
+-- is not a symbol (in which case we'd have a varsym), and that it's not a
+-- space followed by a Haddock comment symbol (docsym) (in which case we'd
+-- have a Haddock comment). The rules then munch the rest of the line.
+
+"-- " ~$docsym .* ;
+"--" [^$symbol : \ ] .* ;
+
+-- Next, match Haddock comments if no -haddock flag
+
+"-- " $docsym .* / { ifExtension (not . haddockEnabled) } ;
+
+-- Now, when we've matched comments that begin with 2 dashes and continue
+-- with a different character, we need to match comments that begin with three
+-- or more dashes (which clearly can't be Haddock comments). We only need to
+-- make sure that the first non-dash character isn't a symbol, and munch the
+-- rest of the line.
+
+"---"\-* [^$symbol :] .* ;
+
+-- Since the previous rules all match dashes followed by at least one
+-- character, we also need to match a whole line filled with just dashes.
+
+"--"\-* / { atEOL } ;
+
+-- We need this rule since none of the other single line comment rules
+-- actually match this case.
+
+"-- " / { atEOL } ;
-- 'bol' state: beginning of a line. Slurp up all the whitespace (including
-- blank lines) until we find a non-whitespace character, then do layout
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
- "{-#" { nested_comment }
+ "{-#" $whitechar* (DOCOPTIONS|docoptions)
+ / { ifExtension haddockEnabled } { lex_string_prag ITdocOptions }
+
+ "{-#" { nested_comment lexToken }
-- ToDo: should only be valid inside a pragma:
"#-}" { token ITclose_prag}
<0,option_prags,glaexts> {
-- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
- "{-#" $whitechar* $idchar+ { nested_comment }
+ "{-#" $whitechar* $idchar+ { nested_comment lexToken }
}
-- '0' state: ordinary lexemes
-- 'glaexts' state: glasgow extensions (postfix '#', etc.)
+-- Haddock comments
+
+<0,glaexts> {
+ "-- " / $docsym { multiline_doc_comment }
+ "{-" \ ? / $docsym { nested_doc_comment }
+}
+
-- "special" symbols
<0,glaexts> {
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
+
+ -- Documentation annotations
+ | ITdocCommentNext String -- something beginning '-- |'
+ | ITdocCommentPrev String -- something beginning '-- ^'
+ | ITdocCommentNamed String -- something beginning '-- $'
+ | ITdocSection Int String -- a section heading
+ | ITdocOptions String -- doc options (prune, ignore-exports, etc)
+
#ifdef DEBUG
deriving Show -- debugging
#endif
notFollowedBySymbol _ _ _ (AI _ _ buf)
= atEnd buf || currentChar buf `notElem` "!#$%&*+./<=>?@\\^|-~"
+isNormalComment bits _ _ (AI _ _ buf)
+ = (if haddockEnabled bits then False else (followedBySpaceDoc buf))
+ || notFollowedByDocOrPragma
+ where
+ notFollowedByDocOrPragma = not $ spaceAndP buf
+ (\buf' -> currentChar buf' `elem` "|^*$#")
+
+spaceAndP buf p = p buf || currentChar buf == ' ' && p buf'
+ where buf' = snd (nextChar buf)
+
+followedBySpaceDoc buf = spaceAndP buf followedByDoc
+
+followedByDoc buf = currentChar buf `elem` "|^*$"
+
+haddockDisabledAnd p bits _ _ (AI _ _ buf)
+ = if haddockEnabled bits then False else (p buf)
+
atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
ifExtension pred bits _ _ _ = pred bits
+multiline_doc_comment :: Action
+multiline_doc_comment span buf _len = withLexedDocType (worker "")
+ where
+ worker commentAcc input docType oneLine = case alexGetChar input of
+ Just ('\n', input')
+ | oneLine -> docCommentEnd input commentAcc docType buf span
+ | otherwise -> case checkIfCommentLine input' of
+ Just input -> worker ('\n':commentAcc) input docType False
+ Nothing -> docCommentEnd input commentAcc docType buf span
+ Just (c, input) -> worker (c:commentAcc) input docType oneLine
+ Nothing -> docCommentEnd input commentAcc docType buf span
+
+ checkIfCommentLine input = check (dropNonNewlineSpace input)
+ where
+ check input = case alexGetChar input of
+ Just ('-', input) -> case alexGetChar input of
+ Just ('-', input) -> case alexGetChar input of
+ Just (c, _) | c /= '-' -> Just input
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+
+ dropNonNewlineSpace input = case alexGetChar input of
+ Just (c, input')
+ | isSpace c && c /= '\n' -> dropNonNewlineSpace input'
+ | otherwise -> input
+ Nothing -> input
+
{-
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
-nested_comment :: Action
-nested_comment span _str _len = do
+nested_comment :: P (Located Token) -> Action
+nested_comment cont span _str _len = do
input <- getInput
go 1 input
- where go 0 input = do setInput input; lexToken
- go n input = do
- case alexGetChar input of
- Nothing -> err input
- Just (c,input) -> do
- case c of
- '-' -> do
- case alexGetChar input of
- Nothing -> err input
- Just ('\125',input) -> go (n-1) input
- Just (c,_) -> go n input
- '\123' -> do
- case alexGetChar input of
- Nothing -> err input
- Just ('-',input') -> go (n+1) input'
- Just (c,input) -> go n input
- c -> go n input
-
- err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
-
+ where
+ go 0 input = do setInput input; cont
+ go n input = case alexGetChar input of
+ Nothing -> errBrace input span
+ Just ('-',input) -> case alexGetChar input of
+ Nothing -> errBrace input span
+ Just ('\125',input) -> go (n-1) input
+ Just (c,_) -> go n input
+ Just ('\123',input) -> case alexGetChar input of
+ Nothing -> errBrace input span
+ Just ('-',input) -> go (n+1) input
+ Just (c,_) -> go n input
+ Just (c,input) -> go n input
+
+nested_doc_comment :: Action
+nested_doc_comment span buf _len = withLexedDocType (go "")
+ where
+ go commentAcc input docType _ = case alexGetChar input of
+ Nothing -> errBrace input span
+ Just ('-',input) -> case alexGetChar input of
+ Nothing -> errBrace input span
+ Just ('\125',input@(AI end _ buf2)) ->
+ docCommentEnd input commentAcc docType buf span
+ Just (c,_) -> go ('-':commentAcc) input docType False
+ Just ('\123', input) -> case alexGetChar input of
+ Nothing -> errBrace input span
+ Just ('-',input) -> do
+ setInput input
+ let cont = do input <- getInput; go commentAcc input docType False
+ nested_comment cont span buf _len
+ Just (c,_) -> go ('\123':commentAcc) input docType False
+ Just (c,input) -> go (c:commentAcc) input docType False
+
+withLexedDocType lexDocComment = do
+ input <- getInput
+ case alexGetChar input of
+ Nothing -> error "Can't happen"
+ Just ('|', input) -> lexDocComment input ITdocCommentNext False
+ Just ('^', input) -> lexDocComment input ITdocCommentPrev False
+ Just ('$', input) -> lexDocComment input ITdocCommentNamed False
+ Just ('*', input) -> lexDocSection 1 input
+ where
+ lexDocSection n input = case alexGetChar input of
+ Just ('*', input) -> lexDocSection (n+1) input
+ Just (c, _) -> lexDocComment input (ITdocSection n) True
+ Nothing -> do setInput input; lexToken -- eof reached, lex it normally
+
+-- docCommentEnd
+-------------------------------------------------------------------------------
+-- This function is quite tricky. We can't just return a new token, we also
+-- need to update the state of the parser. Why? Because the token is longer
+-- than what was lexed by Alex, and the lexToken function doesn't know this, so
+-- it writes the wrong token length to the parser state. This function is
+-- called afterwards, so it can just update the state.
+
+-- This is complicated by the fact that Haddock tokens can span multiple lines,
+-- which is something that the original lexer didn't account for.
+-- I have added last_line_len in the parser state which represents the length
+-- of the part of the token that is on the last line. It is now used for layout
+-- calculation in pushCurrentContext instead of last_len. last_len is, like it
+-- was before, the full length of the token, and it is now only used for error
+-- messages. /Waern
+
+docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
+ SrcSpan -> P (Located Token)
+docCommentEnd input commentAcc docType buf span = do
+ setInput input
+ let (AI loc last_offs nextBuf) = input
+ comment = reverse commentAcc
+ span' = mkSrcSpan (srcSpanStart span) loc
+ last_len = byteDiff buf nextBuf
+
+ last_line_len = if (last_offs - last_len < 0)
+ then last_offs
+ else last_len
+
+ span `seq` setLastToken span' last_len last_line_len
+ return (L span' (docType comment))
+
+errBrace (AI end _ _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
+
open_brace, close_brace :: Action
open_brace span _str _len = do
ctx <- getContext
data LayoutContext
= NoLayout
| Layout !Int
+ deriving Show
data ParseResult a
= POk PState a
-- beginning of the current line.
-- \t is equal to 8 spaces.
last_len :: !Int, -- len of previous token
+ last_line_len :: !Int,
loc :: SrcLoc, -- current loc (end of prev token + 1)
extsBitmap :: !Int, -- bitmap that determines permitted extensions
context :: [LayoutContext],
getSrcLoc :: P SrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
-setLastToken :: SrcSpan -> Int -> P ()
-setLastToken loc len = P $ \s -> POk s{ last_loc=loc, last_len=len } ()
+setLastToken :: SrcSpan -> Int -> Int -> P ()
+setLastToken loc len line_len = P $ \s -> POk s {
+ last_loc=loc,
+ last_len=len,
+ last_line_len=line_len
+} ()
data AlexInput = AI SrcLoc {-#UNPACK#-}!Int StringBuffer
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
idxTysBit = 9 -- indexed type families: 'family' keyword and kind sigs
+haddockBit = 10 -- Lex and parse Haddock comments
glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
glaExtsEnabled flags = testBit flags glaExtsBit
tvEnabled flags = testBit flags tvBit
bangPatEnabled flags = testBit flags bangPatBit
idxTysEnabled flags = testBit flags idxTysBit
+haddockEnabled flags = testBit flags haddockBit
-- PState for parsing options pragmas
--
pragState :: StringBuffer -> SrcLoc -> PState
pragState buf loc =
PState {
- buffer = buf,
- last_loc = mkSrcSpan loc loc,
- last_offs = 0,
- last_len = 0,
- loc = loc,
- extsBitmap = 0,
- context = [],
- lex_state = [bol, option_prags, 0]
+ buffer = buf,
+ last_loc = mkSrcSpan loc loc,
+ last_offs = 0,
+ last_len = 0,
+ last_line_len = 0,
+ loc = loc,
+ extsBitmap = 0,
+ context = [],
+ lex_state = [bol, option_prags, 0]
}
mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
mkPState buf loc flags =
PState {
- buffer = buf,
- last_loc = mkSrcSpan loc loc,
- last_offs = 0,
- last_len = 0,
- loc = loc,
- extsBitmap = fromIntegral bitmap,
- context = [],
- lex_state = [bol, if glaExtsEnabled bitmap then glaexts else 0]
+ buffer = buf,
+ last_loc = mkSrcSpan loc loc,
+ last_offs = 0,
+ last_len = 0,
+ last_line_len = 0,
+ loc = loc,
+ extsBitmap = fromIntegral bitmap,
+ context = [],
+ lex_state = [bol, if glaExtsEnabled bitmap then glaexts else 0]
-- we begin in the layout state if toplev_layout is set
}
where
.|. tvBit `setBitIf` dopt Opt_ScopedTypeVariables flags
.|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
.|. idxTysBit `setBitIf` dopt Opt_IndexedTypes flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
-- This is only used at the outer level of a module when the 'module'
-- keyword is missing.
pushCurrentContext :: P ()
-pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_len=len, context=ctx } ->
- POk s{context = Layout (offs-len) : ctx} ()
+pushCurrentContext = P $ \ s@PState{ last_offs=offs, last_line_len=len, context=ctx } ->
+ POk s{context = Layout (offs-len) : ctx} ()
+--trace ("off: " ++ show offs ++ ", len: " ++ show len) $ POk s{context = Layout (offs-len) : ctx} ()
getOffside :: P Ordering
getOffside = P $ \s@PState{last_offs=offs, context=stk} ->
lexer :: (Located Token -> P a) -> P a
lexer cont = do
- tok@(L _ tok__) <- lexToken
- --trace ("token: " ++ show tok__) $ do
+ tok@(L span tok__) <- lexToken
+-- trace ("token: " ++ show tok__) $ do
cont tok
lexToken :: P (Located Token)
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do let span = mkSrcSpan loc1 loc1
- setLastToken span 0
+ setLastToken span 0 0
return (L span ITeof)
AlexError (AI loc2 _ buf) -> do
reportLexError loc1 loc2 buf "lexical error"
setInput inp2
lexToken
AlexToken inp2@(AI end _ buf2) len t -> do
- setInput inp2
- let span = mkSrcSpan loc1 end
- let bytes = byteDiff buf buf2
- span `seq` setLastToken span bytes
- t span buf bytes
+ setInput inp2
+ let span = mkSrcSpan loc1 end
+ let bytes = byteDiff buf buf2
+ span `seq` setLastToken span bytes bytes
+ t span buf bytes
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
Activation(..), defaultInlineSpec )
import OrdList
+import HaddockParse
+import {-# SOURCE #-} HaddockLex hiding ( Token )
+import HaddockUtils
import FastString
import Maybes ( orElse )
import Monad ( when )
import Outputable
import GLAEXTS
+
+import Data.Char
+import Control.Monad ( mplus )
}
{-
-=chak
-----------------------------------------------------------------------------
-Conflicts: 36 shift/reduce (1.25)
+Conflicts: 38 shift/reduce (1.25)
10 for abiguity in 'if x then y else z + 1' [State 178]
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
This saves explicitly defining a grammar for the rule lhs that
doesn't include 'forall'.
+1 for ambiguity when the source file starts with "-- | doc". We need another
+ token of lookahead to determine if a top declaration or the 'module' keyword
+ follows. Shift parses as if the 'module' keyword follows.
+
-- ---------------------------------------------------------------------------
-- Adding location info
PRIMINTEGER { L _ (ITprimint _) }
PRIMFLOAT { L _ (ITprimfloat _) }
PRIMDOUBLE { L _ (ITprimdouble _) }
-
+
+ DOCNEXT { L _ (ITdocCommentNext _) }
+ DOCPREV { L _ (ITdocCommentPrev _) }
+ DOCNAMED { L _ (ITdocCommentNamed _) }
+ DOCSECTION { L _ (ITdocSection _ _) }
+ DOCOPTIONS { L _ (ITdocOptions _) }
+
-- Template Haskell
'[|' { L _ ITopenExpQuote }
'[p|' { L _ ITopenPatQuote }
-- know what they are doing. :-)
module :: { Located (HsModule RdrName) }
- : 'module' modid maybemoddeprec maybeexports 'where' body
- {% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule (Just $2) $4 (fst $6) (snd $6) $3)) }
+ : optdoc 'module' modid maybemoddeprec maybeexports 'where' body
+ {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
+ return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
+ opt info doc) )}}
| missing_module_keyword top close
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing
- (fst $2) (snd $2) Nothing)) }
+ (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo
+ Nothing)) }
+
+optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+ : moduleheader { (Nothing, fst $1, snd $1) }
+ | docoptions { (Just $1, emptyHaddockModInfo, Nothing)}
+ | docoptions moduleheader { (Just $1, fst $2, snd $2) }
+ | moduleheader docoptions { (Just $2, fst $1, snd $1) }
+ | {- empty -} { (Nothing, emptyHaddockModInfo, Nothing) }
missing_module_keyword :: { () }
: {- empty -} {% pushCurrentContext }
-- Module declaration & imports only
header :: { Located (HsModule RdrName) }
- : 'module' modid maybemoddeprec maybeexports 'where' header_body
- {% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule (Just $2) $4 $6 [] $3)) }
+ : optdoc 'module' modid maybemoddeprec maybeexports 'where' header_body
+ {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
+ return (L loc (HsModule (Just $3) $5 $7 [] $4
+ opt info doc))}}
| missing_module_keyword importdecls
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule Nothing Nothing $2 [] Nothing)) }
+ return (L loc (HsModule Nothing Nothing $2 [] Nothing
+ Nothing emptyHaddockModInfo Nothing)) }
header_body :: { [LImportDecl RdrName] }
: '{' importdecls { $2 }
: '(' exportlist ')' { Just $2 }
| {- empty -} { Nothing }
-exportlist :: { [LIE RdrName] }
- : ',' { [] }
+exportlist :: { [LIE RdrName] }
+ : expdoclist ',' expdoclist { $1 ++ $3 }
| exportlist1 { $1 }
exportlist1 :: { [LIE RdrName] }
- : export { [$1] }
- | export ',' exportlist { $1 : $3 }
- | {- empty -} { [] }
-
+ : expdoclist export expdoclist ',' exportlist { $1 ++ ($2 : $3) ++ $5 }
+ | expdoclist export expdoclist { $1 ++ ($2 : $3) }
+ | expdoclist { $1 }
+
+expdoclist :: { [LIE RdrName] }
+ : exp_doc expdoclist { $1 : $2 }
+ | {- empty -} { [] }
+
+exp_doc :: { LIE RdrName }
+ : docsection { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) }
+ | docnamed { L1 (IEDocNamed ((fst . unLoc) $1)) }
+ | docnext { L1 (IEDoc (unLoc $1)) }
+
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { LIE RdrName }
-- Top-Level Declarations
topdecls :: { OrdList (LHsDecl RdrName) }
- : topdecls ';' topdecl { $1 `appOL` $3 }
- | topdecls ';' { $1 }
- | topdecl { $1 }
+ : topdecls ';' topdecl { $1 `appOL` $3 }
+ | topdecls ';' { $1 }
+ | topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
: cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
| ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | 'instance' inst_type where
- { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
- in unitOL (L (comb3 $1 $2 $3)
- (InstD (InstDecl $2 binds sigs ats))) }
+ | 'instance' inst_type where
+ { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+ in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats))) }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
--
cl_decl :: { LTyClDecl RdrName }
: 'class' tycl_hdr fds where
- {% do { let { (binds, sigs, ats) =
+ {% do { let { (binds, sigs, ats, docs) =
cvBindsAndSigs (unLoc $4)
; (ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms -- only type vars allowed
; checkKindSigs ats
; return $ L (comb4 $1 $2 $3 $4)
(mkClassDecl (ctxt, tc, tvs)
- (unLoc $3) sigs binds ats) } }
+ (unLoc $3) sigs binds ats docs) } }
-- Type declarations (toplevel)
--
| decl { $1 }
| {- empty -} { noLoc nilOL }
-
decllist :: { Located (OrdList (LHsDecl RdrName)) }
: '{' decls '}' { LL (unLoc $2) }
| vocurly decls close { $2 }
| 'threadsafe' { PlaySafe True }
fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
- : STRING var '::' sigtype { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
- | var '::' sigtype { LL (noLoc nilFS, $1, $3) }
+ : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
+ | var '::' sigtypedoc { LL (noLoc nilFS, $1, $3) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
-- convention
: ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
+sigtypedoc :: { LHsType RdrName }
+ : ctypedoc { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
+ -- Wrap an Implicit forall if there isn't one there already
+
sig_vars :: { Located [Located RdrName] }
: sig_vars ',' var { LL ($3 : unLoc $1) }
| var { L1 [$1] }
-----------------------------------------------------------------------------
-- Types
+infixtype :: { LHsType RdrName }
+ : btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 }
+ | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 }
+
+infixtypedoc :: { LHsType RdrName }
+ : infixtype { $1 }
+ | infixtype docprev { LL $ HsDocTy $1 $2 }
+
+gentypedoc :: { LHsType RdrName }
+ : btype { $1 }
+ | btypedoc { $1 }
+ | infixtypedoc { $1 }
+ | btype '->' ctypedoc { LL $ HsFunTy $1 $3 }
+ | btypedoc '->' ctypedoc { LL $ HsFunTy $1 $3 }
+
+ctypedoc :: { LHsType RdrName }
+ : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
+ | context '=>' gentypedoc { LL $ mkImplicitHsForAllTy $1 $3 }
+ -- A type of form (context => type) is an *implicit* HsForAllTy
+ | gentypedoc { $1 }
+
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
| '{-# UNPACK' '#-}' '!' { LL HsUnbox }
: btype atype { LL $ HsAppTy $1 $2 }
| atype { $1 }
+btypedoc :: { LHsType RdrName }
+ : btype atype docprev { LL $ HsDocTy (L (comb2 $1 $2) (HsAppTy $1 $2)) $3 }
+ | atype docprev { LL $ HsDocTy $1 $2 }
+
atype :: { LHsType RdrName }
: gtycon { L1 (HsTyVar (unLoc $1)) }
| tyvar { L1 (HsTyVar (unLoc $1)) }
-- XXX revisit audreyt
| constr_stuff_record '::' sigtype
{ let (con,details) = unLoc $1 in
- LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) }
+ LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing) }
{-
| forall context '=>' constr_stuff_record '::' sigtype
{ let (con,details) = unLoc $4 in
- LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6)) }
+ LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6) Nothing ) }
| forall constr_stuff_record '::' sigtype
{ let (con,details) = unLoc $2 in
- LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4)) }
+ LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4) Nothing) }
-}
constrs :: { Located [LConDecl RdrName] }
: {- empty; a GHC extension -} { noLoc [] }
- | '=' constrs1 { LL (unLoc $2) }
+ | maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
constrs1 :: { Located [LConDecl RdrName] }
- : constrs1 '|' constr { LL ($3 : unLoc $1) }
- | constr { L1 [$1] }
+ : constrs1 maybe_docnext '|' maybe_docprev constr { LL (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) }
+ | constr { L1 [$1] }
constr :: { LConDecl RdrName }
- : forall context '=>' constr_stuff
- { let (con,details) = unLoc $4 in
- LL (ConDecl con Explicit (unLoc $1) $2 details ResTyH98) }
- | forall constr_stuff
- { let (con,details) = unLoc $2 in
- LL (ConDecl con Explicit (unLoc $1) (noLoc []) details ResTyH98) }
+ : maybe_docnext forall context '=>' constr_stuff maybe_docprev
+ { let (con,details) = unLoc $5 in
+ L (comb4 $2 $3 $4 $5) (ConDecl con Explicit (unLoc $2) $3 details ResTyH98 ($1 `mplus` $6)) }
+ | maybe_docnext forall constr_stuff maybe_docprev
+ { let (con,details) = unLoc $3 in
+ L (comb2 $2 $3) (ConDecl con Explicit (unLoc $2) (noLoc []) details ResTyH98 ($1 `mplus` $4)) }
forall :: { Located [LHsTyVarBndr RdrName] }
: 'forall' tv_bndrs '.' { LL $2 }
: oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
-fielddecls :: { [([Located RdrName], LBangType RdrName)] }
- : fielddecl ',' fielddecls { unLoc $1 : $3 }
- | fielddecl { [unLoc $1] }
+fielddecls :: { [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] }
+ : fielddecl maybe_docnext ',' maybe_docprev fielddecls { addFieldDoc (unLoc $1) $4 : addFieldDocs $5 $2 }
+ | fielddecl { [unLoc $1] }
-fielddecl :: { Located ([Located RdrName], LBangType RdrName) }
- : sig_vars '::' ctype { LL (reverse (unLoc $1), $3) }
+fielddecl :: { Located ([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName)) }
+ : maybe_docnext sig_vars '::' ctype maybe_docprev { L (comb3 $2 $3 $4) (reverse (unLoc $2), $4, $1 `mplus` $5) }
-- We allow the odd-looking 'inst_type' in a deriving clause, so that
-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
We can't tell whether to reduce var to qvar until after we've read the signatures.
-}
+docdecl :: { LHsDecl RdrName }
+ : docdecld { L1 (DocD (unLoc $1)) }
+
+docdecld :: { LDocDecl RdrName }
+ : docnext { L1 (DocCommentNext (unLoc $1)) }
+ | docprev { L1 (DocCommentPrev (unLoc $1)) }
+ | docnamed { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
+ | docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }
+
decl :: { Located (OrdList (LHsDecl RdrName)) }
: sigdecl { $1 }
| '!' infixexp rhs {% do { pat <- checkPattern $2;
- return (LL $ unitOL $ LL $ ValD $
+ return (LL $ unitOL $ LL $ ValD (
PatBind (LL $ BangPat pat) (unLoc $3)
- placeHolderType placeHolderNames) } }
+ placeHolderType placeHolderNames)) } }
| infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
return (LL $ unitOL (LL $ ValD r)) } }
+ | docdecl { LL $ unitOL $1 }
rhs :: { Located (GRHSs RdrName) }
: '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
: '|' quals '=' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
- : infixexp '::' sigtype
+ : infixexp '::' sigtypedoc
{% do s <- checkValSig $1 $3;
return (LL $ unitOL (LL $ SigD s)) }
-- See the above notes for why we need infixexp here
- | var ',' sig_vars '::' sigtype
+ | var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
| '{-# INLINE' activation qvar '#-}'
{ LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
+ { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
| t <- $4] }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
{ LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
| ',' { 2 }
-----------------------------------------------------------------------------
+-- Documentation comments
+
+docnext :: { LHsDoc RdrName }
+ : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
+ Left err -> parseError (getLoc $1) err;
+ Right doc -> return (L1 doc) } }
+
+docprev :: { LHsDoc RdrName }
+ : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
+ Left err -> parseError (getLoc $1) err;
+ Right doc -> return (L1 doc) } }
+
+docnamed :: { Located (String, (HsDoc RdrName)) }
+ : DOCNAMED {%
+ let string = getDOCNAMED $1
+ (name, rest) = break isSpace string
+ in case parseHaddockParagraphs (tokenise rest) of {
+ Left err -> parseError (getLoc $1) err;
+ Right doc -> return (L1 (name, doc)) } }
+
+docsection :: { Located (n, HsDoc RdrName) }
+ : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
+ case parseHaddockString (tokenise doc) of {
+ Left err -> parseError (getLoc $1) err;
+ Right doc -> return (L1 (n, doc)) } }
+
+docoptions :: { String }
+ : DOCOPTIONS { getDOCOPTIONS $1 }
+
+moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+ : DOCNEXT {% let string = getDOCNEXT $1 in
+ case parseModuleHeader string of {
+ Right (str, info) ->
+ case parseHaddockParagraphs (tokenise str) of {
+ Left err -> parseError (getLoc $1) err;
+ Right doc -> return (info, Just doc);
+ };
+ Left err -> parseError (getLoc $1) err
+ } }
+
+maybe_docprev :: { Maybe (LHsDoc RdrName) }
+ : docprev { Just $1 }
+ | {- empty -} { Nothing }
+
+maybe_docnext :: { Maybe (LHsDoc RdrName) }
+ : docnext { Just $1 }
+ | {- empty -} { Nothing }
{
happyError :: P a
getINLINE (L _ (ITinline_prag b)) = b
getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
+getDOCNEXT (L _ (ITdocCommentNext x)) = x
+getDOCPREV (L _ (ITdocCommentPrev x)) = x
+getDOCNAMED (L _ (ITdocCommentNamed x)) = x
+getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
+getDOCOPTIONS (L _ (ITdocOptions x)) = x
+
-- Utilities for combining source spans
comb2 :: Located a -> Located b -> SrcSpan
comb2 = combineLocs
| '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
con_info = PrefixCon [toHsType $2] }
in [noLoc $ ConDecl (noLoc dc_name) Explicit []
- (noLoc []) con_info ResTyH98]) }
+ (noLoc []) con_info ResTyH98 Nothing]) }
cons :: { [LConDecl RdrName] }
: {- empty -} { [] } -- 20060420 Empty data types allowed. jds
con :: { LConDecl RdrName }
: d_pat_occ attv_bndrs hs_atys
- { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98 Nothing }
| d_pat_occ '::' ty
-- XXX - audreyt - $3 needs to be split into argument and return types!
-- also not sure whether the [] below (quantified vars) appears.
-- also we want to munge $3 somehow.
-- extractWhatEver to unpack ty into the parts to ConDecl
-- XXX - define it somewhere in RdrHsSyn
- { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) Nothing }
attv_bndrs :: { [LHsTyVarBndr RdrName] }
: {- empty -} { [] }
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
- cvBindsAndSigs,
+ cvBindsAndSigs,
cvTopDecls,
findSplice, mkGroup,
extract_lctxt cx (extract_lty ty []))
where
locals = hsLTyVarNames tvs
+ HsDocTy ty doc -> extract_lty ty acc
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
tcdMeths = mbinds,
- tcdATs = ats
+ tcdATs = ats,
+ tcdDocs = docs
}
mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
--- Declaration list may only contain value bindings and signatures
---
+-- Declaration list may only contain value bindings and signatures.
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, []) -> -- list of type decls *always* empty
+ (mbs, sigs, [], _) -> -- list of type decls *always* empty
ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
+ -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
--- associated type declarations
+-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs fb = go (fromOL fb)
where
- go [] = (emptyBag, [], [])
- go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
- where (bs, ss, ts) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+ go [] = (emptyBag, [], [], [])
+ go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
+ where (bs, ss, ts, docs) = go ds
+ go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
where (b', ds') = getMonoBind (L l b) ds
- (bs, ss, ts) = go ds'
- go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
- where (bs, ss, ts) = go ds
+ (bs, ss, ts, docs) = go ds'
+ go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
+ where (bs, ss, ts, docs) = go ds
+ go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs)
+ where (bs, ss, ts, docs) = go ds
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
+-- All Haddock comments between equations inside the group are
+-- discarded.
+--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
fun_matches = MatchGroup mtchs1 _ })) binds
| has_args mtchs1
- = go is_infix1 mtchs1 loc1 binds
+ = go is_infix1 mtchs1 loc1 binds []
where
go is_infix mtchs loc
(L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
- fun_matches = MatchGroup mtchs2 _ })) : binds)
+ fun_matches = MatchGroup mtchs2 _ })) : binds) _
| f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
- (combineSrcSpans loc loc2) binds
- go is_infix mtchs loc binds
- = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
+ (combineSrcSpans loc loc2) binds []
+ go is_infix mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls
+ = let doc_decls' = doc_decl : doc_decls
+ in go is_infix mtchs (combineSrcSpans loc loc2) binds doc_decls'
+ go is_infix mtchs loc binds doc_decls
+ = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), (reverse doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order
+ -- Do the same thing with the trailing doc comments
getMonoBind bind binds = (bind, binds)
add gp l (SpliceD e) ds = (gp, Just (e, ds))
-- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
+ l decl@(TyClD d) ds
| isClassDecl d =
let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
- addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds
+ addl (gp { hs_tyclds = L l d : ts,
+ hs_fixds = fsigs ++ fs,
+ hs_docs = add_doc decl docs}) ds
| otherwise =
- addl (gp { hs_tyclds = L l d : ts }) ds
+ addl (gp { hs_tyclds = L l d : ts,
+ hs_docs = add_doc decl docs }) ds
-- Signatures: fixity sigs go a different place than all others
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
- = addl (gp {hs_valds = add_sig (L l d) ts}) ds
+add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
+ = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
-- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
- = addl (gp { hs_valds = add_bind (L l d) ts }) ds
+add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds
+ = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
-- The rest are routine
add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
= addl (gp { hs_derivds = L l d : ts }) ds
add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
= addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
- = addl (gp { hs_fords = L l d : ts }) ds
+add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds
+ = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
= addl (gp { hs_depds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
+add gp l (DocD d) ds
+ = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds
+
+add_doc decl docs = case getMainDeclBinder decl of
+ Just name -> DeclEntity name : docs
+ Nothing -> docs
+
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
\end{code}
return (data_con, PrefixCon ts)
split (L l _) _ = parseError l "parse error in data/newtype declaration"
-mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
- -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
+mkRecCon :: Located RdrName ->
+ [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
+ P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
mkRecCon (L loc con) fields
= do data_con <- tyConToDataCon loc con
- return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])
+ return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
return (TuplePat ps b placeHolderType)
RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
- return (ConPatIn c (RecCon fs))
+ return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
-- Generics
HsType ty -> return (TypePat ty)
_ -> patFail loc
, con_qvars = qvars
, con_cxt = cxt
, con_details = PrefixCon []
- , con_res = ResTyGADT ty }
+ , con_res = ResTyGADT ty
+ , con_doc = Nothing }
-- NB: we put the whole constr type into the ResTyGADT for now;
-- the renamer will unravel it once it has sorted out
-- operator fixities
lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
lookupLocatedInstDeclBndr,
lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
+ lookupGreRn,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
--- /dev/null
+module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc, rnMbHsDoc ) where
+
+import TcRnMonad ( RnM )
+import RnEnv ( dataTcOccs, lookupGreRn )
+import HsDoc ( HsDoc(..) )
+
+import RdrName ( RdrName, isRdrDataCon, isRdrTc, gre_name )
+import Name ( Name )
+import SrcLoc ( Located(..) )
+import Outputable ( ppr, defaultUserStyle )
+
+import Data.List ( (\\) )
+import Debug.Trace ( trace )
+
+rnMbHsDoc mb_doc = case mb_doc of
+ Just doc -> do
+ doc' <- rnHsDoc doc
+ return (Just doc')
+ Nothing -> return Nothing
+
+rnMbLHsDoc mb_doc = case mb_doc of
+ Just doc -> do
+ doc' <- rnLHsDoc doc
+ return (Just doc')
+ Nothing -> return Nothing
+
+rnLHsDoc (L pos doc) = do
+ doc' <- rnHsDoc doc
+ return (L pos doc')
+
+ids2string [] = []
+ids2string (x:_) = show $ ppr x defaultUserStyle
+
+rnHsDoc :: HsDoc RdrName -> RnM (HsDoc Name)
+rnHsDoc doc = case doc of
+
+ DocEmpty -> return DocEmpty
+
+ DocAppend a b -> do
+ a' <- rnHsDoc a
+ b' <- rnHsDoc b
+ return (DocAppend a' b')
+
+ DocString str -> return (DocString str)
+
+ DocParagraph doc -> do
+ doc' <- rnHsDoc doc
+ return (DocParagraph doc')
+
+ DocIdentifier ids -> do
+ let choices = concatMap dataTcOccs ids
+ mb_gres <- mapM lookupGreRn choices
+ case [gre_name gre | Just gre <- mb_gres] of
+ [] -> return (DocString (ids2string ids))
+ ids' -> return (DocIdentifier ids')
+
+ DocModule str -> return (DocModule str)
+
+ DocEmphasis doc -> do
+ doc' <- rnHsDoc doc
+ return (DocEmphasis doc')
+
+ DocMonospaced doc -> do
+ doc' <- rnHsDoc doc
+ return (DocMonospaced doc')
+
+ DocUnorderedList docs -> do
+ docs' <- mapM rnHsDoc docs
+ return (DocUnorderedList docs')
+
+ DocOrderedList docs -> do
+ docs' <- mapM rnHsDoc docs
+ return (DocOrderedList docs')
+
+ DocDefList list -> do
+ list' <- mapM (\(a,b) -> do
+ a' <- rnHsDoc a
+ b' <- rnHsDoc b
+ return (a', b')) list
+ return (DocDefList list')
+
+ DocCodeBlock doc -> do
+ doc' <- rnHsDoc doc
+ return (DocCodeBlock doc')
+
+ DocURL str -> return (DocURL str)
+
+ DocAName str -> return (DocAName str)
`unionNameSets` getl ty)
`minusNameSet`
mkNameSet (hsLTyVarNames tvs)
+ get (HsDocTy ty _) = getl ty
extractHsTyNames_s :: [LHsType Name] -> NameSet
extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys)
conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
-conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds]
+conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (HsRecField _ bty _) <- flds]
bangTyFVs bty = extractHsTyNames (getBangType bty)
\end{code}
instDeclATs, isIdxTyDecl,
LIE )
import RnEnv
+import RnHsDoc ( rnHsDoc )
import IfaceEnv ( ifaceExportNames )
import LoadIface ( loadSrcInterface )
import TcRnMonad hiding (LIE)
; succeed_with True (name:names) }
get_item (IEVar name)
= succeed_with True [name]
-
+ get_item (IEGroup _ _)
+ = succeed_with False []
+ get_item (IEDoc _)
+ = succeed_with False []
+ get_item (IEDocNamed _)
+ = succeed_with False []
\end{code}
return (IEThingWith name names)
rnExport (IEModuleContents mod)
= return (IEModuleContents mod)
+ rnExport (IEGroup lev doc)
+ = do rn_doc <- rnHsDoc doc
+ return (IEGroup lev rn_doc)
+ rnExport (IEDoc doc)
+ = do rn_doc <- rnHsDoc doc
+ return (IEDoc rn_doc)
+ rnExport (IEDocNamed str)
+ = return (IEDocNamed str)
+
rn_exports <- mapM (wrapLocM rnExport) exports
return (Just rn_exports)
+filterOutDocs = filter notDoc
+ where
+ notDoc (L _ (IEGroup _ _)) = False
+ notDoc (L _ (IEDoc _)) = False
+ notDoc (L _ (IEDocNamed _)) = False
+ notDoc _ = True
+
mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all
-> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list
-> RnM NameSet
return (Just ([noLoc (IEVar mainName)]
,[noLoc (IEVar main_RDR_Unqual)]))
-- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope
- exports_from_avail real_exports rdr_env imports
+
+ -- we don't want to include Haddock comments
+ let real_exports' = fmap (\(a,b) -> (filterOutDocs a, filterOutDocs b)) real_exports
+
+ exports_from_avail real_exports' rdr_env imports
exports_from_avail Nothing rdr_env imports
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
- lookupOccRn, newLocalsRn,
+ lookupOccRn, lookupTopBndrRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalNames, checkDupNames, mapFvRn
)
+import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
import HscTypes ( FixityEnv, FixItem(..),
hs_depds = deprec_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
- hs_ruleds = rule_decls })
+ hs_ruleds = rule_decls,
+ hs_docs = docs })
= do { -- Deal with deprecations (returns only the extra deprecations)
deprecs <- rnSrcDeprecDecls deprec_decls ;
<- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
(rn_default_decls, src_fvs5)
<- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-
+
+ rn_docs <- mapM rnDocEntity docs ;
+
let {
rn_group = HsGroup { hs_valds = rn_val_decls,
hs_tyclds = rn_tycl_decls,
hs_depds = [],
hs_fords = rn_foreign_decls,
hs_defds = rn_default_decls,
- hs_ruleds = rn_rule_decls } ;
+ hs_ruleds = rn_rule_decls,
+ hs_docs = rn_docs } ;
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3,
src_fvs4, src_fvs5] ;
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
+rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name)
+rnDocEntity (DocEntity docdecl) = do
+ rn_docdecl <- rnDocDecl docdecl
+ return (DocEntity rn_docdecl)
+rnDocEntity (DeclEntity name) = do
+ rn_name <- lookupTopBndrRn name
+ return (DeclEntity rn_name)
+
+rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl (DocCommentNext doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocGroup lev rn_doc)
+
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
rnTyClDecls tycl_decls = do
(decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds, tcdATs = ats})
+ tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
= lookupLocatedTopBndrRn cname `thenM` \ cname' ->
-- Tyvars scope over superclass context and method signatures
rnFds cls_doc fds `thenM` \ fds' ->
rnATs ats `thenM` \ (ats', ats_fvs) ->
renameSigs okClsDclSig sigs `thenM` \ sigs' ->
- returnM (tyvars', context', fds', (ats', ats_fvs), sigs')
- ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
+ mapM rnDocEntity docs `thenM` \ docs' ->
+ returnM (tyvars', context', fds', (ats', ats_fvs), sigs', docs')
+ ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs', docs') ->
-- Check for duplicates among the associated types
let
returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
- tcdMeths = mbinds', tcdATs = ats'},
+ tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
= mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name expl tvs cxt details res_ty)
+rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
= do { addLocM checkConName name
; new_name <- lookupLocatedTopBndrRn name
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
; bindTyVarsRn doc tvs' $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
- ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
- where
+ ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
+ where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
mappM (rnField doc) fields `thenM` \ new_fields ->
returnM (RecCon new_fields)
where
- field_names = [fld | (fld, _) <- fields]
+ field_names = [ name | HsRecField name _ _ <- fields ]
-rnField doc (name, ty)
+-- Document comments are renamed to Nothing here
+rnField doc (HsRecField name ty haddock_doc)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
rnLHsType doc ty `thenM` \ new_ty ->
- returnM (new_name, new_ty)
+ rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc ->
+ returnM (HsRecField new_name new_ty new_haddock_doc)
-- Rename kind signatures (signatures of indexed data types/newtypes and
-- signatures of type functions)
import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name,
listTyCon_name
)
+import RnHsDoc ( rnLHsDoc )
import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
lookupLocatedOccRn, lookupLocatedBndrRn,
lookupLocatedGlobalOccRn, bindTyVarsRn,
= do { addErr (ptext SLIT("Type splices are not yet implemented"))
; failM }
+rnHsType doc (HsDocTy ty haddock_doc)
+ = rnLHsType doc ty `thenM` \ ty' ->
+ rnLHsDoc haddock_doc `thenM` \ haddock_doc' ->
+ returnM (HsDocTy ty' haddock_doc')
+
rnLHsTypes doc tys = mappM (rnLHsType doc) tys
\end{code}
-- -----------------------------------------------------------------------------
-- rnRpats
-rnRpats :: [(Located RdrName, LPat RdrName)]
- -> RnM ([(Located Name, LPat Name)], FreeVars)
+-- Haddock comments for record fields are renamed to Nothing here
+rnRpats :: [HsRecField RdrName (LPat RdrName)]
+ -> RnM ([HsRecField Name (LPat Name)], FreeVars)
rnRpats rpats
= mappM_ field_dup_err dup_fields `thenM_`
mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) ->
returnM (rpats', fvs)
where
- (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
+ (_, dup_fields) = removeDups compare [ unLoc f | HsRecField f _ _ <- rpats ]
field_dup_err dups = addErr (dupFieldErr "pattern" dups)
- rn_rpat (field, pat)
+ rn_rpat (HsRecField field pat _)
= lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
rnLPat pat `thenM` \ (pat', fvs) ->
- returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
+ returnM ((mkRecField fieldname pat'), fvs `addOneFV` unLoc fieldname)
\end{code}
; return (env', InfixCon p1' p2') }
zonkConStuff env (RecCon rpats)
- = do { (env', pats') <- zonkPats env pats
- ; returnM (env', RecCon (fields `zip` pats')) }
- where
- (fields, pats) = unzip rpats
+ = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ]
+ ; (env', pats') <- zonkPats env pats
+ ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ]
+ ; returnM (env', recCon) }
---------------------------
zonkPats env [] = return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
- ; (env', pats') <- zonkPats env1 pats
- ; return (env', pat':pats') }
+ ; (env', pats') <- zonkPats env1 pats
+ ; return (env', pat':pats') }
\end{code}
%************************************************************************
kc_hs_type ty@(HsSpliceTy _)
= failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty)
+-- remove the doc nodes here, no need to worry about the location since
+-- its the same for a doc node and it's child type node
+kc_hs_type (HsDocTy ty _)
+ = kc_hs_type (unLoc ty)
---------------------------
kcApps :: TcKind -- Function kind
import {-# SOURCE #-} TcExpr( tcSyntaxOp )
import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..),
HsOverLit(..), HsExpr(..), HsWrapper(..),
- mkCoPat,
+ mkCoPat, HsRecField(..), mkRecField,
LHsBinds, emptyLHsBinds, isEmptyLHsBinds,
- collectPatsBinders, nlHsLit )
+ collectPatsBinders, nlHsLit,
+ LHsDoc )
import TcHsSyn ( TcId, hsLitType )
import TcRnMonad
import Inst ( InstOrigin(..), shortCutFracLit, shortCutIntLit,
= do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
; return (RecCon rpats', tvs, res) }
where
- tc_field :: Checker (Located Name, LPat Name) (Located TcId, LPat TcId)
- tc_field (field_lbl, pat) pstate thing_inside
+ -- doc comments are typechecked to Nothing here
+ tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
+ tc_field (HsRecField field_lbl pat _) pstate thing_inside
= do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
- ; return ((sel_id, pat'), tvs, res) }
+ ; return (mkRecField sel_id pat', tvs, res) }
find_field_ty :: FieldLabel -> TcM (Id, TcType)
find_field_ty field_lbl
import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
SpliceDecl(..), HsBind(..), LHsBinds,
emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
- nlHsApp, nlHsVar, pprLHsBinds )
+ nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) )
import RdrHsSyn ( findSplice )
import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
+import RnHsDoc ( rnMbHsDoc )
import PprCore ( pprRules, pprCoreBindings )
import CoreSyn ( CoreRule, bindersOfBinds )
import ErrUtils ( Messages, mkDumpDoc, showPass )
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
- import_decls local_decls mod_deprec))
+ import_decls local_decls mod_deprec _ module_info maybe_doc))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
reportDeprecations (hsc_dflags hsc_env) tcg_env ;
-- Process the export list
- rn_exports <- rnExports export_ies;
+ rn_exports <- rnExports export_ies ;
+
+ -- Rename the Haddock documentation header
+ rn_module_doc <- rnMbHsDoc maybe_doc ;
+
+ -- Rename the Haddock module info
+ rn_description <- rnMbHsDoc (hmi_description module_info) ;
+ let { rn_module_info = module_info { hmi_description = rn_description } } ;
+
let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
exports <- mkExportNameSet (isJust maybe_mod)
(liftM2' (,) rn_exports export_ies) ;
else Nothing,
tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
- mod_deprecs }
+ mod_deprecs,
+ tcg_doc = rn_module_doc,
+ tcg_hmi = rn_module_info
+ }
-- A module deprecation over-rides the earlier ones
} ;
import TcEnv ( tcExtendIdEnv )
#endif
-import HsSyn ( emptyLHsBinds )
+import HsSyn ( emptyLHsBinds, HaddockModInfo(..) )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
ExternalPackageState(..), HomePackageTable,
tcg_rules = [],
tcg_fords = [],
tcg_dfun_n = dfun_n_var,
- tcg_keep = keep_var
+ tcg_keep = keep_var,
+ tcg_doc = Nothing,
+ tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup,
- HsWrapper, IE )
+ HsWrapper, IE, HsDoc, HaddockModInfo )
import HscTypes ( FixityEnv,
HscEnv, TypeEnv, TyThing,
GenAvailInfo(..), AvailInfo, HscSource(..),
tcg_deprecs :: Deprecations, -- ...Deprecations
tcg_insts :: [Instance], -- ...Instances
tcg_rules :: [LRuleDecl Id], -- ...Rules
- tcg_fords :: [LForeignDecl Id] -- ...Foreign import & exports
+ tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports
+
+ tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation
+ tcg_hmi :: HaddockModInfo Name -- Haddock module information
}
\end{code}
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
- ConDecl(..), Sig(..), NewOrData(..), ResType(..),
+ ConDecl(..), HsRecField(..), Sig(..), NewOrData(..), ResType(..),
tyClDeclTyVars, isSynDecl, isIdxTyDecl,
isKindSigDecl, hsConArgs, LTyClDecl, tcdName,
hsTyVarName, LHsTyVarBndr, LHsType
; cons' <- mappM (wrapLocM kc_con_decl) cons
; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
where
- kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do
+ -- doc comments are typechecked to Nothing here
+ kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) = do
kcHsTyVars ex_tvs $ \ex_tvs' -> do
ex_ctxt' <- kcHsContext ex_ctxt
details' <- kc_con_details details
res' <- case res of
ResTyH98 -> return ResTyH98
ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
- return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
+ return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
kc_con_details (PrefixCon btys)
= do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
kc_con_details (RecCon fields)
= do { fields' <- mappM kc_field fields; return (RecCon fields') }
- kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') }
+ kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) }
kc_larg_ty bty = case new_or_data of
DataType -> kcHsSigType bty
-> TcM DataCon
tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes
- (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
+ (ConDecl name _ ex_tvs ex_ctxt details ResTyH98 _)
= do { let tc_datacon field_lbls arg_ty
= do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
; buildDataCon (unLoc name) False {- Prefix -}
; case details of
PrefixCon [arg_ty] -> tc_datacon [] arg_ty
- RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty
+ RecCon [HsRecField field_lbl arg_ty _] -> tc_datacon [field_lbl] arg_ty
other ->
failWithTc (newtypeFieldErr name (length (hsConArgs details)))
-- Check that the constructor has exactly one field
}
tcConDecl unbox_strict DataType tycon tc_tvs -- Data types
- (ConDecl name _ tvs ctxt details res_ty)
+ (ConDecl name _ tvs ctxt details res_ty _)
= tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty
InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
RecCon fields -> tc_datacon False field_names btys
where
- (field_names, btys) = unzip fields
+ (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ]
}
projects / ghc-hetmet.git / commitdiff