aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs48
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs145
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs167
-rw-r--r--haddock-api/src/Haddock/Convert.hs67
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs48
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs86
-rw-r--r--haddock-api/src/Haddock/Utils.hs31
9 files changed, 297 insertions, 309 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 55075e20..b7dfad64 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -64,7 +64,8 @@ dropHsDocTy :: HsType a -> HsType a
dropHsDocTy = f
where
g (L src x) = L src (f x)
- f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e)
+ f (HsForAllTy a e) = HsForAllTy a (g e)
+ f (HsQualTy a e) = HsQualTy a (g e)
f (HsBangTy a b) = HsBangTy a (g b)
f (HsAppTy a b) = HsAppTy (g a) (g b)
f (HsFunTy a b) = HsFunTy (g a) (g b)
@@ -81,14 +82,6 @@ outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
-makeExplicit :: HsType a -> HsType a
-makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d
-makeExplicit x = x
-
-makeExplicitL :: LHsType a -> LHsType a
-makeExplicitL (L src x) = L src (makeExplicit x)
-
-
dropComment :: String -> String
dropComment (' ':'-':'-':' ':_) = []
dropComment (x:xs) = x : dropComment xs
@@ -120,40 +113,29 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
f (TyClD d@ClassDecl{}) = ppClass dflags d
- f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
- f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ []
+ f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+ f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
f (SigD sig) = ppSig dflags sig
f _ = []
ppExport _ _ = []
ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig _)
- = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
- where
- prettyNames = intercalate ", " $ map (out dflags) names
- typ = case unL sig of
- HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d
- HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d
- x -> x
+ppSig dflags (TypeSig names sig) = pp_sig dflags names (hsSigWcType sig)
ppSig _ _ = []
+pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> [String]
+pp_sig dflags names (L _ typ)
+ = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
+ where
+ prettyNames = intercalate ", " $ map (out dflags) names
-- note: does not yet output documentation for class methods
ppClass :: DynFlags -> TyClDecl Name -> [String]
ppClass dflags x = out dflags x{tcdSigs=[]} :
- concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
- where
- addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs
- addContext (MinimalSig src sig) = MinimalSig src sig
- addContext _ = error "expected TypeSig"
-
- f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d
- f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t)
-
- context = nlHsTyConApp (tcdName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
-
+ concatMap (ppSig dflags . unL . add_ctxt) (tcdSigs x)
+ where
+ add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
ppInstance :: DynFlags -> ClsInst -> [String]
ppInstance dflags x = [dropComment $ out dflags x]
@@ -194,10 +176,10 @@ ppCtor dflags dat subdocs con
[out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
+ funs = foldr1 (\x y -> reL $ HsFunTy x y)
apps = foldl1 (\x y -> reL $ HsAppTy x y)
- typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
name = out dflags $ map unL $ con_names con
resType = case con_res con of
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 68149b41..3514f74e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -213,9 +213,9 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
- | Map.null argDocs = Just (map unLoc lnames, t)
+ | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
@@ -250,8 +250,8 @@ ppDocGroup lev doc = sec lev <> braces doc
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]
+ 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"
@@ -293,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
-- TyClD d@(TySynonym {})
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- 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 qtvs prov req ty) ->
- ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode
+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
+ SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
+ (hsSigWcType t) unicode
+ SigD (PatSynSig lname ty) ->
+ ppLPatSig loc (doc, fnArgsDoc) lname ty unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
@@ -311,8 +312,8 @@ ppTyFam _ _ _ _ _ =
ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
-ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =
- ppFunSig loc doc [name] typ unicode
+ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =
+ ppFunSig loc doc [name] (hsSigType typ) unicode
ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -329,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype }) unicode
= ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
- hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
+ hdr = hsep (keyword "type"
+ : ppDocBinder name
+ : map ppSymName (tyvarNames ltyvars))
full = hdr <+> char '=' <+> ppLType unicode ltype
ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
@@ -340,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName
-> Bool -> LaTeX
-ppFunSig loc doc docnames typ unicode =
+ppFunSig loc doc docnames (L _ typ) unicode =
ppTypeOrFunSig loc docnames typ doc
( ppTypeSig names typ False
, hsep . punctuate comma $ map ppSymName names
@@ -352,29 +355,17 @@ ppFunSig loc doc docnames typ unicode =
names = map getName docnames
ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
- -> (HsExplicitFlag, LHsTyVarBndrs DocName)
- -> LHsContext DocName -> LHsContext DocName
- -> LHsType DocName
+ -> LHsSigType DocName
-> Bool -> LaTeX
-ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode
+ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode
= declWithDoc pref1 (documentationToLaTeX doc)
where
pref1 = hsep [ keyword "pattern"
, ppDocBinder name
, dcolon unicode
- , ppLTyVarBndrs expl qtvs unicode
- , ctx
- , ppType unicode ty
+ , ppLType unicode (hsSigType ty)
]
- 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
-
- darr = darrow unicode
-
ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
-> Bool -> LaTeX
@@ -393,23 +384,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
- do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
- do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype)
- = decltt leader <->
- decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
- ppLContextNoArrow lctxt unicode) <+> nl $$
- do_largs n (darrow unicode) ltype
-
- do_args n leader (HsForAllTy Qualified e a lctxt ltype)
- = do_args n leader (HsForAllTy Implicit e a lctxt ltype)
- do_args n leader (HsForAllTy Implicit _ _ lctxt ltype)
- | not (null (unLoc lctxt))
- = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
- do_largs n (darrow unicode) ltype
- -- if we're not showing any 'forall' or class constraints or
- -- anything, skip having an empty line for the context.
- | otherwise
- = do_largs n leader ltype
+ do_args :: Int -> LaTeX -> HsType DocName -> LaTeX
+ do_args _n leader (HsForAllTy tvs ltype)
+ = decltt leader
+ <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
+ <+> ppLType unicode ltype
+ do_args n leader (HsQualTy lctxt ltype)
+ = decltt leader
+ <-> ppLContextNoArrow lctxt unicode <+> nl $$
+ do_largs n (darrow unicode) ltype
do_args n leader (HsFunTy lt r)
= decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
do_largs (n+1) (arrow unicode) r
@@ -424,12 +407,12 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
-ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
-ppTyVars tvs = map ppSymName (tyvarNames tvs)
+ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
+ppTyVars = map (ppSymName . getName . hsLTyVarName)
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
+tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -478,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
+ -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
<+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
- <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+ <+> ppAppDocNameNames summ n (tyvarNames tvs)
<+> ppFds fds unicode
@@ -521,8 +504,8 @@ ppClassDecl instances loc doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig loc doc names typ unicode
- | L _ (TypeSig lnames (L _ typ) _) <- lsigs
+ vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode
+ | L _ (TypeSig lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -613,21 +596,20 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX
+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX
ppConstrHdr forall tvs ctxt unicode
= (if null tvs then empty else ppForall)
<+>
(if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
where
ppForall = case forall of
- Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
- Qualified -> empty
- Implicit -> empty
+ True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
+ False -> empty
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
-> LConDecl DocName -> LaTeX
-ppSideBySideConstr subdocs unicode leader (L _ con) =
+ppSideBySideConstr subdocs unicode leader (L loc con) =
leader <->
case con_res con of
ResTyH98 -> case con_details con of
@@ -661,13 +643,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
doRecordFields fields =
vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
- doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs (con_cxt con) unicode,
- ppLType unicode (foldr mkFunTy resTy args) ]
+ doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>
+ ppLType unicode (mk_forall $ mk_phi $
+ foldr mkFunTy resTy args)
) <-> rDoc mbDoc
- header_ = ppConstrHdr forall tyVars context
+ header_ = ppConstrHdr (con_explicit con) tyVars context
occ = map (nameOccName . getName . unLoc) $ con_names con
ppOcc = case occ of
[one] -> ppBinder one
@@ -675,7 +657,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
- forall = con_explicit con
+
+ mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+ | otherwise = ty
+ mk_phi ty | null context = ty
+ | otherwise = L loc (HsQualTy (con_cxt con) ty)
+
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
mbDoc = case con_names con of
@@ -791,9 +778,6 @@ 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
@@ -879,34 +863,19 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Located (HsContext DocName) -> Bool -> LaTeX
-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}
-
ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
= maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
- where
- anonWC :: HsType DocName
- anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
- underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
- ctxt'
- | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
- | otherwise = ctxt
+ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ , ppr_mono_lty pREC_TOP ty unicode ]
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
+ = maybeParen ctxt_prec pREC_FUN $
+ sep [ ppLContext ctxt unicode
+ , ppr_mono_lty pREC_TOP ty unicode ]
ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index b2710703..31757eeb 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -584,7 +584,7 @@ processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0
(DataDecl{}) -> [keyword "data" <+> b]
(SynDecl{}) -> [keyword "type" <+> b]
(ClassDecl {}) -> [keyword "class" <+> b]
- SigD (TypeSig lnames (L _ _) _) ->
+ SigD (TypeSig lnames _) ->
map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
_ -> []
processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8996fc87..b0a4f503 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -45,13 +45,14 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
- 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 qtvs prov req ty) ->
- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ 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
+ (hsSigWcType lty) fixities splice unicode qual
+ SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname
+ 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"
@@ -61,26 +62,23 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
- ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
+ ppFunSig summary links loc doc (map unLoc lnames) lty fixities
splice unicode qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
+ [DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
- ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
+ ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
splice unicode qual
where
- pp_typ = ppType unicode qual typ
+ pp_typ = ppLType unicode qual typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- Located DocName ->
- (HsExplicitFlag, LHsTyVarBndrs DocName) ->
- LHsContext DocName -> LHsContext DocName ->
- LHsType DocName ->
+ Located DocName -> LHsSigType DocName ->
[(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual
| summary = pref1
| otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
+++ docSection Nothing qual doc
@@ -88,18 +86,9 @@ ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq t
pref1 = hsep [ keyword "pattern"
, ppBinder summary occname
, dcolon unicode
- , ppLTyVarBndrs expl qtvs unicode qual
- , cxt
- , ppLType unicode qual typ
+ , ppLType unicode qual (hsSigType typ)
]
- 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
-
- darr = darrow unicode
occname = nameOccName . getName $ name
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
@@ -133,22 +122,29 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
argDoc n = Map.lookup n argDocs
do_largs n leader (L _ t) = do_args n leader t
+
do_args :: Int -> Html -> HsType DocName -> [SubDecl]
- do_args n leader (HsForAllTy _ _ tvs lctxt ltype)
- = case unLoc lctxt of
- [] -> do_largs n leader' ltype
- _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
- : do_largs n (darrow unicode) ltype
- where leader' = leader <+> ppForAll tvs unicode qual
+ do_args n leader (HsForAllTy tvs ltype)
+ = do_largs n leader' ltype
+ where
+ leader' = leader <+> ppForAll tvs unicode qual
+
+ do_args n leader (HsQualTy lctxt ltype)
+ | null (unLoc lctxt)
+ = do_largs n leader ltype
+ | otherwise
+ = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
+ : do_largs n (darrow unicode) ltype
+
do_args n leader (HsFunTy lt r)
= (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
= [(leader <+> ppType unicode qual t, argDoc n, [])]
-ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html
+ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
- case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of
+ case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of
[] -> noHtml
ts -> forallSymbol unicode <+> hsep ts +++ dot
where ppKTv n k = parens $
@@ -176,20 +172,19 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
rightEdge = thespan ! [theclass "rightedge"] << noHtml
-ppTyVars :: LHsTyVarBndrs DocName -> [Html]
-ppTyVars tvs = map ppTyName (tyvarNames tvs)
+ppTyVars :: [LHsTyVarBndr DocName] -> [Html]
+ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
-
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
+tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> ForeignDecl DocName -> [(DocName, Fixity)]
-> Splice -> Unicode -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
+ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities
splice unicode qual
- = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
+ = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual
ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
@@ -204,7 +199,8 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
(full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
splice unicode qual
where
- hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
+ hdr = hsep ([keyword "type", ppBinder summary occ]
+ ++ ppTyVars (hsQTvBndrs ltyvars))
full = hdr <+> equals <+> ppLType unicode qual ltype
occ = nameOccName . getName $ name
fixs
@@ -290,7 +286,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
-- Individual equation of a closed type family
ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
- , tfe_pats = HsWB { hswb_cts = ts }}
+ , tfe_pats = HsIB { hsib_body = ts }}
= ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
<+> equals <+> ppType unicode qual (unLoc rhs)
, Nothing, [] )
@@ -363,10 +359,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
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 cxt unicode qual = fromMaybe noHtml $
ppContextNoLocsMaybe (map unLoc cxt) unicode qual
@@ -397,7 +389,7 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
+ -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
@@ -430,8 +422,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc doc names typ [] splice unicode qual
- | L _ (TypeSig lnames (L _ typ) _) <- sigs
+ [ ppFunSig summary links loc doc names (hsSigWcType typ)
+ [] splice unicode qual
+ | L _ (TypeSig lnames typ) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -475,8 +468,9 @@ ppClassDecl summary links instances fixities loc d subdocs
doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
- methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
- | L _ (TypeSig lnames (L _ typ) _) <- lsigs
+ methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)
+ subfixs splice unicode qual
+ | L _ (ClassOpSig _ lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
subfixs = [ f | n <- names
, f@(n',_) <- fixities
@@ -489,12 +483,12 @@ ppClassDecl summary links instances fixities loc d subdocs
minimalBit = case [ s | L _ (MinimalSig _ (L _ s)) <- lsigs ] of
-- Miminal complete definition = every shown method
And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
- sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns]
+ sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
-> noHtml
-- Minimal complete definition = the only shown method
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns]
+ [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
-> noHtml
-- Minimal complete definition = nothing
@@ -666,23 +660,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode
-> Qualification -> Html
ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
+++
- (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
- <+> darrow unicode +++ toHtml " ")
+ (if null ctxt then noHtml
+ else ppContextNoArrow ctxt unicode qual
+ <+> darrow unicode +++ toHtml " ")
where
- ppForall = case forall_ of
- Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "
- Qualified -> noHtml
- Implicit -> noHtml
-
+ ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
+ <+> toHtml ". "
+ | otherwise = noHtml
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
-> Unicode -> Qualification -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
+ppSideBySideConstr subdocs fixities unicode qual (L loc con)
+ = (decl, mbDoc, fieldPart)
where
decl = case con_res con of
ResTyH98 -> case con_details con of
@@ -712,12 +706,19 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
doRecordFields fields = subFields qual
(map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
+
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
doGADTCon args resTy = ppOcc <+> dcolon unicode
- <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual,
- ppLType unicode qual (foldr mkFunTy resTy args) ]
+ <+> ppLType unicode qual (mk_forall $ mk_phi $
+ foldr mkFunTy resTy args)
<+> fixity
+ mk_phi ty | null context = ty
+ | otherwise = L loc (HsQualTy (con_cxt con) ty)
+
+ mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+ | otherwise = ty
+
fixity = ppFixities fixities qual
header_ = ppConstrHdr forall_ tyVars context unicode qual
occ = map (nameOccName . getName . unLoc) $ con_names con
@@ -850,38 +851,36 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
+ppForAllCon :: Bool -> LHsQTyVars DocName
+ -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
ppForAllCon expl tvs 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
+ppLTyVarBndrs :: Bool -> LHsQTyVars DocName -> Unicode -> Qualification -> Html
+ppLTyVarBndrs show_forall tvs unicode _qual
+ | show_forall
+ , not (null tv_bndrs) = ppForAllPart tv_bndrs unicode
+ | otherwise = noHtml
where
- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
- is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
+ tv_bndrs = hsQTvBndrs tvs
+ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html
+ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual
- = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual
- <+> ppr_mono_lty pREC_TOP ty unicode qual
- where
- anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
- underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
- ctxt'
- | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
- | otherwise = ctxt
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual
+ = maybeParen ctxt_prec pREC_FUN $
+ ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual
+
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
+ = maybeParen ctxt_prec pREC_FUN $
+ ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
-- UnicodeSyntax alternatives
ppr_mono_ty _ (HsTyVar name) True _
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index a61e3696..ce71cf86 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -96,17 +96,10 @@ tyThingToLHsDecl t = case t of
-- a data-constructor alone just gets rendered as a function:
AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]
- (synifyType ImplicitizeForAll (dataConUserType dc)) [])
+ (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- let (univ_tvs, req_theta, ex_tvs, 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)
- (Implicit, synifyTyVars qtvs)
- (synifyCtx req_theta)
- (synifyCtx prov_theta)
- (synifyType WithinType ty)
+ allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType (patSynType ps))
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -118,10 +111,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
hs_rhs = synifyType WithinType rhs
(kvs, tvs) = partition isKindVar tkvs
in TyFamEqn { tfe_tycon = name
- , tfe_pats = HsWB { hswb_cts = typats
- , hswb_kvs = map tyVarName kvs
- , hswb_tvs = map tyVarName tvs
- , hswb_wcs = [] }
+ , tfe_pats = HsIB { hsib_body = typats
+ , hsib_kvs = map tyVarName kvs
+ , hsib_tvs = map tyVarName tvs }
, tfe_rhs = hs_rhs }
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -305,32 +297,40 @@ synifyDataCon use_gadt_syntax dc =
else ResTyH98
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
- \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care
- qvars ctx hat hs_res_ty Nothing
+ \hat -> return $ noLoc $
+ ConDecl { con_names = [name]
+ , con_explicit = False -- we don't know nor care
+ , con_qvars = qvars
+ , con_cxt = ctx
+ , con_details = hat
+ , con_res = hs_res_ty
+ , con_doc = Nothing }
synifyName :: NamedThing n => n -> Located Name
synifyName = noLoc . getName
synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) []
+synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))
synifyCtx :: [PredType] -> LHsContext Name
synifyCtx = noLoc . map (synifyType WithinType)
-synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars :: [TyVar] -> LHsQTyVars Name
synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
, hsq_tvs = map synifyTyVar tvs }
where
(kvs, tvs) = partition isKindVar ktvs
- synifyTyVar tv
- | isLiftedTypeKind kind = noLoc (UserTyVar name)
- | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
- where
- kind = tyVarKind tv
- name = getName tv
+
+synifyTyVar :: TyVar -> LHsTyVarBndr Name
+synifyTyVar tv
+ | isLiftedTypeKind kind = noLoc (UserTyVar name)
+ | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))
+ where
+ kind = tyVarKind tv
+ name = getName tv
--states of what to do with foralls:
data SynifyTypeState
@@ -348,6 +348,15 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
+synifySigType :: SynifyTypeState -> Type -> LHsSigType Name
+-- The empty binders is a bit suspicious;
+-- what if the type has free variables?
+synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)
+
+synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
+-- Ditto (see synifySigType)
+synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
+
synifyType :: SynifyTypeState -> Type -> LHsType Name
synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
synifyType _ (TyConApp tc tys)
@@ -386,15 +395,13 @@ synifyType _ (FunTy t1 t2) = let
in noLoc $ HsFunTy s1 s2
synifyType s forallty@(ForAllTy _tv _ty) =
let (tvs, ctx, tau) = tcSplitSigmaTy forallty
- sTvs = synifyTyVars tvs
- sCtx = synifyCtx ctx
- sTau = synifyType WithinType tau
- mkHsForAllTy forallPlicitness =
- noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau
+ sPhi = HsQualTy { hst_ctxt = synifyCtx ctx
+ , hst_body = synifyType WithinType tau }
in case s of
DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
- WithinType -> mkHsForAllTy Explicit
- ImplicitizeForAll -> mkHsForAllTy Implicit
+ WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs
+ , hst_body = noLoc sPhi }
+ ImplicitizeForAll -> noLoc sPhi
synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index aa9a1c32..49d6a420 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -69,7 +69,7 @@ getMainDeclBinder _ = []
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
getInstLoc (TyFamInstD (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
@@ -92,10 +92,10 @@ filterSigNames p (FixSig (FixitySig ns ty)) =
[] -> Nothing
filtered -> Just (FixSig (FixitySig filtered ty))
filterSigNames _ orig@(MinimalSig _ _) = Just orig
-filterSigNames p (TypeSig ns ty nwcs) =
+filterSigNames p (TypeSig ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
- filtered -> Just (TypeSig filtered ty nwcs)
+ filtered -> Just (TypeSig filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -106,8 +106,8 @@ sigName :: LSig name -> [name]
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig ns _ _) = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig n _) = [unLoc n]
sigNameNoLoc (SpecSig n _ _) = [unLoc n]
sigNameNoLoc (InlineSig n _) = [unLoc n]
sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
@@ -199,7 +199,7 @@ instance Parent (TyClDecl Name) where
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ]
+ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 9b8bbe50..4d45ff9b 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -345,15 +345,14 @@ typeDocs :: HsDecl Name -> Map Int HsDocString
typeDocs d =
let docs = go 0 in
case d of
- SigD (TypeSig _ ty _) -> docs (unLoc ty)
- 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)
+ SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
+ SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
+ ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty))
TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
_ -> M.empty
where
- go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty)
+ go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+ go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
go n (HsDocTy _ (L _ doc)) = M.singleton n doc
@@ -726,8 +725,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
expandSig = foldr f []
where
f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
- f (L l (SigD (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : 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 (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names
f x xs = x : xs
mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
@@ -771,17 +770,17 @@ extractDecl name mdl decl
case unLoc decl of
TyClD d@ClassDecl {} ->
let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
- isVanillaLSig sig ] -- TODO: document fixity
+ isTypeLSig sig ] -- TODO: document fixity
in case matches of
- [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
- L pos sig = extractClassDecl n tyvar_names s0
+ [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)
+ L pos sig = addClassContext n tyvar_names s0
in L pos (SigD sig)
_ -> error "internal: extractDecl (ClassDecl)"
TyClD d@DataDecl {} ->
- let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
- in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+ let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
+ in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
- , dfid_pats = HsWB { hswb_cts = tys }
+ , dfid_pats = HsIB { hsib_body = tys }
, dfid_defn = defn }) ->
SigD <$> extractRecSel name mdl n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
@@ -795,24 +794,6 @@ extractDecl name mdl decl
[d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
- where
- getTyVars = hsLTyVarLocNames . tyClDeclTyVars
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc = noLoc . HsTyVar . unLoc
-
-
-extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c tvs0 (L pos (TypeSig lname ltype _)) = case ltype of
- L _ (HsForAllTy expl _ tvs (L _ preds) ty) ->
- L pos (TypeSig lname (noLoc (HsForAllTy expl Nothing tvs (lctxt preds) ty)) [])
- _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) [])
- where
- lctxt = noLoc . ctxt
- ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
-extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
-
extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
@@ -821,7 +802,7 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (L _ con : rest) =
case con_details con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
- L l (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) [])
+ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
_ -> extractRecSel nm mdl t tvs rest
where
matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
@@ -831,7 +812,6 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
| ResTyGADT _ ty <- con_res con = ty
| otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
-
-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
pruneExportItems = filter hasDoc
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 131082cd..3640d348 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -170,6 +170,12 @@ renameFnArgsDoc = mapM renameDoc
renameLType :: LHsType Name -> RnM (LHsType DocName)
renameLType = mapM renameType
+renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
+renameLSigType = renameImplicit renameLType
+
+renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
+renameLSigWcType = renameImplicit (renameWc renameLType)
+
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
@@ -198,11 +204,15 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameType :: HsType Name -> RnM (HsType DocName)
renameType t = case t of
- HsForAllTy expl extra tyvars lcontext ltype -> do
- tyvars' <- renameLTyVarBndrs tyvars
+ HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
+ tyvars' <- mapM renameLTyVarBndr tyvars
+ ltype' <- renameLType ltype
+ return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+
+ HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsForAllTy expl extra tyvars' lcontext' ltype')
+ return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
HsTyVar n -> return . HsTyVar =<< rename n
HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
@@ -252,10 +262,10 @@ renameType t = case t of
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
-renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
-renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)
+renameLHsQTyVars (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
= do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLHsQTyVars", hsq_tvs = tvs' }) }
-- This is rather bogus, but I'm not sure what else to do
renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
@@ -320,13 +330,13 @@ renameTyClD d = case d of
SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do
lname' <- renameL lname
- tyvars' <- renameLTyVarBndrs tyvars
+ tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })
DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do
lname' <- renameL lname
- tyvars' <- renameLTyVarBndrs tyvars
+ tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames })
@@ -334,7 +344,7 @@ renameTyClD d = case d of
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
+ ltyvars' <- renameLHsQTyVars ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
ats' <- mapM (renameLThing renameFamilyDecl) ats
@@ -358,7 +368,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdInjectivityAnn = injectivity }) = do
info' <- renameFamilyInfo info
lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
+ ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
return (FamilyDecl { fdInfo = info', fdLName = lname'
@@ -387,7 +397,7 @@ renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars
, con_cxt = lcontext, con_details = details
, con_res = restype, con_doc = mbldoc }) = do
lnames' <- mapM renameL lnames
- ltyvars' <- renameLTyVarBndrs ltyvars
+ ltyvars' <- renameLHsQTyVars ltyvars
lcontext' <- renameLContext lcontext
details' <- renameDetails details
restype' <- renameResType restype
@@ -423,17 +433,14 @@ renameLFieldOcc (L l (FieldOcc lbl sel)) = do
renameSig :: Sig Name -> RnM (Sig DocName)
renameSig sig = case sig of
- TypeSig lnames ltype _ -> do
+ TypeSig lnames ltype -> do
lnames' <- mapM renameL lnames
- ltype' <- renameLType ltype
- return (TypeSig lnames' ltype' PlaceHolder)
- PatSynSig lname (flag, qtvs) lreq lprov lty -> do
+ ltype' <- renameLSigWcType ltype
+ return (TypeSig lnames' ltype')
+ PatSynSig lname sig_ty -> do
lname' <- renameL lname
- qtvs' <- renameLTyVarBndrs qtvs
- lreq' <- renameLContext lreq
- lprov' <- renameLContext lprov
- lty' <- renameLType lty
- return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'
+ sig_ty' <- renameLSigType sig_ty
+ return $ PatSynSig lname' sig_ty'
FixSig (FixitySig lnames fixity) -> do
lnames' <- mapM renameL lnames
return $ FixSig (FixitySig lnames' fixity)
@@ -447,11 +454,11 @@ renameSig sig = case sig of
renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
renameForD (ForeignImport lname ltype co x) = do
lname' <- renameL lname
- ltype' <- renameLType ltype
+ ltype' <- renameLSigType ltype
return (ForeignImport lname' ltype' co x)
renameForD (ForeignExport lname ltype co x) = do
lname' <- renameL lname
- ltype' <- renameLType ltype
+ ltype' <- renameLSigType ltype
return (ForeignExport lname' ltype' co x)
@@ -470,7 +477,7 @@ renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
, cid_datafam_insts = lADTs }) = do
- ltype' <- renameLType ltype
+ ltype' <- renameLSigType ltype
lATs' <- mapM (mapM renameTyFamInstD) lATs
lADTs' <- mapM (mapM renameDataFamInstD) lADTs
return (ClsInstDecl { cid_overlap_mode = omode
@@ -486,33 +493,48 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
, tfid_fvs = placeHolderNames }) }
renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs }))
+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; pats' <- renameImplicit (mapM renameLType) pats
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
- , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+ , tfe_pats = pats'
, tfe_rhs = rhs' })) }
renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
- = do { tc' <- renameL tc
- ; tvs' <- renameLTyVarBndrs tvs
+ = do { tc' <- renameL tc
+ ; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
, tfe_pats = tvs'
, tfe_rhs = rhs' })) }
renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })
= do { tc' <- renameL tc
- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; pats' <- renameImplicit (mapM renameLType) pats
; defn' <- renameDataDefn defn
; return (DataFamInstDecl { dfid_tycon = tc'
- , dfid_pats
- = HsWB pats' PlaceHolder PlaceHolder PlaceHolder
+ , dfid_pats = pats'
, dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+renameImplicit :: (in_thing -> RnM out_thing)
+ -> HsImplicitBndrs Name in_thing
+ -> RnM (HsImplicitBndrs DocName out_thing)
+renameImplicit rn_thing (HsIB { hsib_body = thing })
+ = do { thing' <- rn_thing thing
+ ; return (HsIB { hsib_body = thing'
+ , hsib_kvs = PlaceHolder, hsib_tvs = PlaceHolder }) }
+
+renameWc :: (in_thing -> RnM out_thing)
+ -> HsWildCardBndrs Name in_thing
+ -> RnM (HsWildCardBndrs DocName out_thing)
+renameWc rn_thing (HsWC { hswc_body = thing })
+ = do { thing' <- rn_thing thing
+ ; return (HsWC { hswc_body = thing'
+ , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
+
renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
renameExportItem item = case item of
ExportModule mdl -> return (ExportModule mdl)
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c2e1b09a..f7a32dd3 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -16,6 +16,7 @@ module Haddock.Utils (
-- * Misc utilities
restrictTo, emptyHsQTvs,
toDescription, toInstalledDescription,
+ mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
-- * Filename utilities
moduleHtmlFile, moduleHtmlFile',
@@ -124,6 +125,34 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo
mkMeta :: Doc a -> MDoc a
mkMeta x = emptyMetaDoc { _doc = x }
+mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
+
+addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
+-- Add the class context to a class-op signature
+addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
+ = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
+ -- The mkEmptySigWcType is suspicious
+ where
+ go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))
+ = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })
+ go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+ = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })
+ go (L loc ty)
+ = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+
+ extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
+
+lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
+lHsQTyVarsToTypes tvs
+ = [ noLoc (HsTyVar (hsLTyVarName tv))
+ | tv <- hsQTvBndrs tvs ]
+
--------------------------------------------------------------------------------
-- * Making abstract declarations
--------------------------------------------------------------------------------
@@ -177,7 +206,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-emptyHsQTvs :: LHsTyVarBndrs Name
+emptyHsQTvs :: LHsQTyVars Name
-- This function is here, rather than in HsTypes, because it *renamed*, but
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-16 01:46:01 +0000