aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/LaTeX.hs44
-rw-r--r--src/Haddock/Backends/Xhtml.hs2
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs71
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs23
-rw-r--r--src/Haddock/Convert.hs12
-rw-r--r--src/Haddock/GhcUtils.hs4
-rw-r--r--src/Haddock/Interface/Create.hs24
-rw-r--r--src/Haddock/Interface/Rename.hs9
8 files changed, 156 insertions, 33 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 4a30a168..94adc558 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -249,6 +249,7 @@ declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
SigD (TypeSig lnames _) -> map unLoc lnames
+ SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
ForD (ForeignImport (L _ n) _ _ _) -> [n]
ForD (ForeignExport (L _ n) _ _ _) -> [n]
_ -> error "declaration not supported by declNames"
@@ -291,6 +292,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
-- Family instances happen via FamInst now
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
@@ -345,6 +348,33 @@ ppFunSig loc doc docnames typ unicode =
where
names = map getName docnames
+ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
+ -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
+ -> LHsContext DocName -> LHsContext DocName
+ -> Bool -> LaTeX
+ppLPatSig loc doc docname args typ prov req unicode =
+ ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode
+
+ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName
+ -> HsPatSynDetails (HsType DocName) -> HsType DocName
+ -> HsContext DocName -> HsContext DocName
+ -> Bool -> LaTeX
+ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)
+ where
+ pref1 = hsep [ keyword "pattern"
+ , pp_ctx prov
+ , pp_head
+ , dcolon unicode
+ , pp_ctx req
+ , ppType unicode typ
+ ]
+
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]
+
+ pp_type = ppParendType unicode
+ pp_ctx ctx = ppContext ctx unicode
ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
@@ -914,9 +944,16 @@ ppr_fun_ty ctxt_prec ty1 ty2 unicode
ppBinder :: OccName -> LaTeX
ppBinder n
- | isVarSym n = parens $ ppOccName n
- | otherwise = ppOccName n
+ | isInfixName n = parens $ ppOccName n
+ | otherwise = ppOccName n
+ppBinderInfix :: OccName -> LaTeX
+ppBinderInfix n
+ | isInfixName n = ppOccName n
+ | otherwise = quotes $ ppOccName n
+
+isInfixName :: OccName -> Bool
+isInfixName n = isVarSym n || isConSym n
ppSymName :: Name -> LaTeX
ppSymName name
@@ -953,6 +990,9 @@ ppLDocName (L _ d) = ppDocName d
ppDocBinder :: DocName -> LaTeX
ppDocBinder = ppBinder . nameOccName . getName
+ppDocBinderInfix :: DocName -> LaTeX
+ppDocBinderInfix = ppBinderInfix . nameOccName . getName
+
ppName :: Name -> LaTeX
ppName = ppOccName . nameOccName
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index d61478a8..567abced 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -598,7 +598,7 @@ ppNameMini :: Module -> OccName -> Html
ppNameMini mdl nm =
anchor ! [ href (moduleNameUrl mdl nm)
, target mainFrameName ]
- << ppBinder' nm
+ << ppBinder' False nm
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 91e6871d..04f94c49 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -30,6 +30,7 @@ import Haddock.Doc (combineDocumentation)
import Data.List ( intersperse )
import qualified Data.Map as Map
import Data.Maybe
+import Data.Monoid ( mempty )
import Text.XHtml hiding ( name, title, p, quote )
import GHC
@@ -40,21 +41,69 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
- SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty unicode qual
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
+ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ [Located DocName] -> LHsType DocName -> Bool -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty unicode qual =
+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) unicode qual
+
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[DocName] -> HsType DocName -> Bool -> Qualification -> Html
ppFunSig summary links loc doc docnames typ unicode qual =
+ ppSigLike summary links loc mempty doc docnames (typ, pp_typ) unicode qual
+ where
+ pp_typ = ppType unicode qual typ
+
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ Located DocName ->
+ HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
+ LHsContext DocName -> LHsContext DocName ->
+ Bool -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req unicode qual =
+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode qual
+
+ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ DocName ->
+ HsPatSynDetails (HsType DocName) -> HsType DocName ->
+ HsContext DocName -> HsContext DocName ->
+ Bool -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qual
+ | summary = pref1
+ | otherwise = topDeclElem links loc [docname] pref1 +++ docSection qual doc
+ where
+ -- pref1 = leader <+> ppTypeSig summary occnames pp_typ unicode
+ pref1 = hsep [ toHtml "pattern"
+ , pp_cxt prov
+ , pp_head
+ , dcolon unicode
+ , pp_cxt req
+ , ppType unicode qual typ
+ ]
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]
+
+ pp_cxt cxt = ppContext cxt unicode qual
+ pp_type = ppParendType unicode qual
+
+ occname = nameOccName . getName $ docname
+
+ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
+ [DocName] -> (HsType DocName, Html) -> Bool -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames (typ, pp_typ) unicode qual =
ppTypeOrFunSig summary links loc docnames typ doc
- ( ppTypeSig summary occnames typ unicode qual
+ ( leader <+> ppTypeSig summary occnames pp_typ unicode
, concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
@@ -127,9 +176,9 @@ ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvar
ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
-ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html
-ppTypeSig summary nms ty unicode qual =
- concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty
+ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
+ppTypeSig summary nms pp_ty unicode =
+ concatHtml htmlNames <+> dcolon unicode <+> pp_ty
where
htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
@@ -465,7 +514,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
char '}')
InfixCon arg1 arg2 ->
(header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppBinder summary occ, ppLParendType unicode qual arg2],
+ ppBinderInfix summary occ, ppLParendType unicode qual arg2],
noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
@@ -526,7 +575,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
InfixCon arg1 arg2 ->
hsep [header_ unicode qual +++ ppLParendType unicode qual arg1,
- ppBinder False occ,
+ ppBinderInfix False occ,
ppLParendType unicode qual arg2]
ResTyGADT resTy -> case con_details con of
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 2f2b82ed..280a888c 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -12,7 +12,7 @@
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
- ppBinder, ppBinder',
+ ppBinder, ppBinderInfix, ppBinder',
ppModule, ppModuleRef,
ppIPName,
linkId
@@ -105,16 +105,23 @@ ppName name = toHtml (getOccString name)
ppBinder :: Bool -> OccName -> Html
-- The Bool indicates whether we are generating the summary, in which case
-- the binder will be a link to the full definition.
-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' False n
ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
- << ppBinder' n
+ << ppBinder' False n
+ppBinderInfix :: Bool -> OccName -> Html
+ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' True n
+ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+ << ppBinder' True n
-ppBinder' :: OccName -> Html
-ppBinder' n
- | isVarSym n = parens $ ppOccName n
- | otherwise = ppOccName n
-
+ppBinder' :: Bool -> OccName -> Html
+-- The Bool indicates if it is to be rendered in infix notation
+ppBinder' is_infix n = wrap $ ppOccName n
+ where
+ wrap | is_infix && not is_sym = quote
+ | not is_infix && is_sym = parens
+ | otherwise = id
+ is_sym = isVarSym n || isConSym n
linkId :: Module -> Maybe Name -> Html -> Html
linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 0f7e5b9c..66497783 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -27,7 +27,9 @@ import Var
import Class
import TyCon
import CoAxiom
+import ConLike
import DataCon
+import PatSyn
import BasicTypes ( TupleSort(..) )
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon )
@@ -85,9 +87,17 @@ tyThingToLHsDecl t = noLoc $ case t of
ACoAxiom ax -> synifyAxiom ax
-- a data-constructor alone just gets rendered as a function:
- ADataCon dc -> SigD (TypeSig [synifyName dc]
+ AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]
(synifyType ImplicitizeForAll (dataConUserType dc)))
+ AConLike (PatSynCon ps) ->
+ let (_, _, (req_theta, prov_theta)) = patSynSig ps
+ in SigD $ PatSynSig (synifyName ps)
+ (fmap (synifyType WithinType) (patSynTyDetails ps))
+ (synifyType WithinType (patSynType ps))
+ (synifyCtx req_theta)
+ (synifyCtx prov_theta)
+
synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
index 467541fc..a8a4f1c9 100644
--- a/src/Haddock/GhcUtils.hs
+++ b/src/Haddock/GhcUtils.hs
@@ -76,6 +76,9 @@ isNameSym = isSymOcc . nameOccName
isVarSym :: OccName -> Bool
isVarSym = isLexVarSym . occNameFS
+isConSym :: OccName -> Bool
+isConSym = isLexConSym . occNameFS
+
getMainDeclBinder :: HsDecl name -> [name]
getMainDeclBinder (TyClD d) = [tcdName d]
@@ -115,6 +118,7 @@ sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [name]
sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
sigNameNoLoc (SpecSig n _ _) = [unLoc n]
sigNameNoLoc (InlineSig n _) = [unLoc n]
sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index 6c20f00b..6e85ad16 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -31,6 +31,7 @@ import Data.Ord
import Control.Applicative
import Control.DeepSeq
import Control.Monad
+import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Packages
@@ -327,6 +328,9 @@ typeDocs d =
let docs = go 0 in
case d of
SigD (TypeSig _ ty) -> docs (unLoc ty)
+ SigD (PatSynSig _ arg_tys ty req prov) ->
+ let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]
+ in F.foldMap (docs . unLoc) allTys
ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
_ -> M.empty
@@ -345,7 +349,7 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
docs = mkDecls tcdDocs DocD class_
- defs = mkDecls (bagToList . tcdMeths) ValD class_
+ defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_
sigs = mkDecls tcdSigs SigD class_
ats = mkDecls tcdATs (TyClD . FamDecl) class_
@@ -360,13 +364,13 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
ungroup :: HsGroup Name -> [LHsDecl Name]
ungroup group_ =
mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls hs_instds InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
- mkDecls (valbinds . hs_valds) ValD group_
+ mkDecls hs_derivds DerivD group_ ++
+ mkDecls hs_defds DefD group_ ++
+ mkDecls hs_fords ForD group_ ++
+ mkDecls hs_docs DocD group_ ++
+ mkDecls hs_instds InstD group_ ++
+ mkDecls (typesigs . hs_valds) SigD group_ ++
+ mkDecls (map snd . valbinds . hs_valds) ValD group_
where
typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
typesigs _ = error "expected ValBindsOut"
@@ -718,8 +722,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls =
expandSig = foldr f []
where
f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
- f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
- f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
f x xs = x : xs
mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 9a4041ee..b4a7e19a 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -398,6 +398,15 @@ renameSig sig = case sig of
lnames' <- mapM renameL lnames
ltype' <- renameLType ltype
return (TypeSig lnames' ltype')
+ PatSynSig lname args ltype lreq lprov -> do
+ lname' <- renameL lname
+ args' <- case args of
+ PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs
+ InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright
+ ltype' <- renameLType ltype
+ lreq' <- renameLContext lreq
+ lprov' <- renameLContext lprov
+ return $ PatSynSig lname' args' ltype' lreq' lprov'
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-29 02:27:11 +0000