aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs70
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs72
-rw-r--r--haddock-api/src/Haddock/Convert.hs21
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs10
5 files changed, 85 insertions, 92 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index e9cc48c2..309e0f76 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/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)
@@ -787,15 +783,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
@@ -870,14 +872,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
@@ -955,11 +959,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
@@ -998,9 +997,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/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 893c2a50..ae01ab6e 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/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) ->
@@ -356,17 +348,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
@@ -813,9 +811,17 @@ ppForAllCon expl tvs cxt unicode qual
| show_forall = forall_part <+> ppLContext cxt unicode qual
| otherwise = 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/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 91581c7a..3b454feb 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -16,7 +16,6 @@ module Haddock.Convert where
-- Some other functions turned out to be useful for converting
-- instance heads, which aren't TyThings, so just export everything.
-
import Bag ( emptyBag )
import BasicTypes ( TupleSort(..) )
import Class
@@ -36,7 +35,7 @@ import PrelNames (ipClassName)
import SrcLoc ( Located, noLoc, unLoc )
import TcType ( tcSplitSigmaTy )
import TyCon
-import Type(isStrLitTy)
+import Type (isStrLitTy, mkFunTys)
import TypeRep
import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, eqTyCon )
@@ -44,6 +43,7 @@ import Unique ( getUnique )
import Var
+
-- the main function here! yay!
tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name))
tyThingToLHsDecl t = case t of
@@ -98,21 +98,14 @@ tyThingToLHsDecl t = case t of
(synifyType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
-#if MIN_VERSION_ghc(7,8,3)
- let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
-#else
- let (_, _, (req_theta, prov_theta)) = patSynSig ps
-#endif
+ 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 allOK . SigD $ PatSynSig (synifyName ps)
-#if MIN_VERSION_ghc(7,8,3)
- (fmap (synifyType WithinType) (patSynTyDetails ps))
- (synifyType WithinType res_ty)
-#else
- (fmap (synifyType WithinType) (patSynTyDetails ps))
- (synifyType WithinType (patSynType ps))
-#endif
+ (Implicit, synifyTyVars qtvs)
(synifyCtx req_theta)
(synifyCtx prov_theta)
+ (synifyType WithinType ty)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 11b8494d..da17ccc7 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -343,8 +343,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/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e9048b53..a5717a58 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -401,15 +401,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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 20:26:23 +0000