diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 06a24b4f9d60095ef77ed3f41ce1d04b5a675042..d30744383f380a954bc57f3d28aedeef793c76ae 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -293,8 +293,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = 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
+ SigD (PatSynSig lname qtvs prov req ty) ->
+ ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
@@ -350,32 +350,28 @@ ppFunSig loc doc docnames typ unicode =
names = map getName docnames
ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
- -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
+ -> (HsExplicitFlag, LHsTyVarBndrs DocName)
-> LHsContext DocName -> LHsContext DocName
+ -> LHsType 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)
+ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode
+ = declWithDoc pref1 (documentationToLaTeX doc)
where
pref1 = hsep [ keyword "pattern"
- , pp_ctx prov
- , pp_head
+ , ppDocBinder name
, dcolon unicode
- , pp_ctx req
- , ppType unicode typ
+ , ppLTyVarBndrs expl qtvs unicode
+ , ctx
+ , ppType unicode ty
]
- 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]
+ ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of
+ (Nothing, Nothing) -> empty
+ (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr
+ (Just prov, Nothing) -> prov <+> darr
+ (Just prov, Just req) -> prov <+> darr <+> req <+> darr
- pp_type = ppParendType unicode
- pp_ctx ctx = ppContext ctx unicode
+ darr = darrow unicode
ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
@@ -786,15 +782,21 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX
+ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
+
+ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX
+ppContextNoLocsMaybe [] _ = Nothing
+ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX
-ppContextNoArrow [] _ = empty
-ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
+ppContextNoArrow cxt unicode = fromMaybe empty $
+ ppContextNoLocsMaybe (map unLoc cxt) unicode
ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
-ppContextNoLocs [] _ = empty
-ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
+ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $
+ ppContextNoLocsMaybe cxt unicode
ppContext :: HsContext DocName -> Bool -> LaTeX
@@ -869,14 +871,16 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-> Located (HsContext DocName) -> Bool -> LaTeX
-ppForAll expl tvs cxt unicode
- | show_forall = forall_part <+> ppLContext cxt unicode
- | otherwise = ppLContext cxt unicode
+ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode
+
+ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
+ -> Bool -> LaTeX
+ppLTyVarBndrs expl tvs unicode
+ | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ | otherwise = empty
where
show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
- forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
-
ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
@@ -954,11 +958,6 @@ ppBinder 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
@@ -997,9 +996,6 @@ 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/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index d4869abdbde86e19c681159e4ac22e2c9859fc87..97f3fb09e9144ef643e3ca6bf53e2e6f20edfa80 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -32,7 +32,6 @@ import Control.Applicative
import Data.List ( intersperse, sort )
import qualified Data.Map as Map
import Data.Maybe
-import Data.Monoid ( mempty )
import Text.XHtml hiding ( name, title, p, quote )
import GHC
@@ -49,8 +48,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
- SigD (PatSynSig lname args ty prov req) ->
- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
+ SigD (PatSynSig lname qtvs prov req ty) ->
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
@@ -74,39 +73,32 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
Located DocName ->
- HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
- LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
+ (HsExplicitFlag, LHsTyVarBndrs DocName) ->
+ LHsContext DocName -> LHsContext DocName ->
+ LHsType DocName ->
+ [(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
- ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
- (unLoc prov) (unLoc req) fixities splice unicode qual
-
-ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- DocName ->
- HsPatSynDetails (HsType DocName) -> HsType DocName ->
- HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
- splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual
| summary = pref1
- | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
+ | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
+++ docSection Nothing qual doc
where
pref1 = hsep [ toHtml "pattern"
- , pp_cxt prov
- , pp_head
+ , ppBinder summary occname
, dcolon unicode
- , pp_cxt req
- , ppType unicode qual typ
+ , ppLTyVarBndrs expl qtvs unicode qual
+ , cxt
+ , ppLType 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
+ cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of
+ (Nothing, Nothing) -> noHtml
+ (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr
+ (Just prov, Nothing) -> prov <+> darr
+ (Just prov, Just req) -> prov <+> darr <+> req <+> darr
- occname = nameOccName . getName $ docname
+ darr = darrow unicode
+ occname = nameOccName . getName $ name
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
@@ -357,17 +349,23 @@ ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html
+ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
+
ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContextNoArrow [] _ _ = noHtml
-ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
+ppContextNoArrow cxt unicode qual = fromMaybe noHtml $
+ ppContextNoLocsMaybe (map unLoc cxt) unicode qual
ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
-ppContextNoLocs [] _ _ = noHtml
-ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
- <+> darrow unicode
+ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $
+ ppContextNoLocsMaybe cxt unicode qual
+ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html
+ppContextNoLocsMaybe [] _ _ = Nothing
+ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual
+
ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
@@ -811,12 +809,19 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
-> Located (HsContext DocName) -> Unicode -> Qualification -> Html
ppForAll expl tvs cxt unicode qual
- | show_forall = forall_part <+> ppLContext cxt unicode qual
- | otherwise = ppLContext cxt unicode qual
+ = forall_part <+> ppLContext cxt unicode qual
+ where
+ forall_part = ppLTyVarBndrs expl tvs unicode qual
+
+ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
+ -> Unicode -> Qualification
+ -> Html
+ppLTyVarBndrs expl tvs unicode _qual
+ | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
+ | otherwise = noHtml
where
show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
- forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index 48306392a8096946cc5a08f0e2655633685f36cf..08892cd3540112b394e828512b2dfc54b0614eff 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -20,7 +20,7 @@ module Haddock.Convert where
import HsSyn
import TcType ( tcSplitSigmaTy )
import TypeRep
-import Type(isStrLitTy)
+import Type ( isStrLitTy, mkFunTys )
import Kind ( splitKindFunTys, synTyConResKind, isKind )
import Name
import Var
@@ -94,12 +94,14 @@ tyThingToLHsDecl t = noLoc $ case t of
(synifyType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
+ let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps
+ qtvs = univ_tvs ++ ex_tvs
+ ty = mkFunTys arg_tys res_ty
in SigD $ PatSynSig (synifyName ps)
- (fmap (synifyType WithinType) (patSynTyDetails ps))
- (synifyType WithinType res_ty)
+ (Implicit, synifyTyVars qtvs)
(synifyCtx req_theta)
(synifyCtx prov_theta)
+ (synifyType WithinType ty)
synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index ad6a1e98d421f5e61d8f72607b7f81e9a4929889..551e6e7e1929cbd70f31b9602927fb60a338a908 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -340,8 +340,8 @@ 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 ]
+ SigD (PatSynSig _ _ req prov ty) ->
+ let allTys = ty : concat [ unLoc req, unLoc prov ]
in F.foldMap (docs . unLoc) allTys
ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index dca93cc0f8782aafe3bafd3bde7b21ff46f9c190..aa1a170feed5909c45d1321d966416748bdb896b 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -402,15 +402,13 @@ renameSig sig = case sig of
lnames' <- mapM renameL lnames
ltype' <- renameLType ltype
return (TypeSig lnames' ltype')
- PatSynSig lname args ltype lreq lprov -> do
+ PatSynSig lname (flag, qtvs) lreq lprov lty -> 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
+ qtvs' <- renameLTyVarBndrs qtvs
lreq' <- renameLContext lreq
lprov' <- renameLContext lprov
- return $ PatSynSig lname' args' ltype' lreq' lprov'
+ lty' <- renameLType lty
+ return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
FixSig (FixitySig lname fixity) -> do
lname' <- renameL lname
return $ FixSig (FixitySig lname' fixity)