From 1a9dcfef033dd66514015d4a942ba67d21f95482 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Wed, 6 Aug 2014 10:26:54 +0200 Subject: Support for PartialTypeSignatures --- src/Haddock/Backends/Hoogle.hs | 20 ++++++++++---------- src/Haddock/Backends/LaTeX.hs | 27 +++++++++++++++++---------- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 33 ++++++++++++++++++++------------- 4 files changed, 48 insertions(+), 34 deletions(-) (limited to 'src/Haddock/Backends') diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index cdd4d56e..1df6d9b1 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -64,7 +64,7 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a b c d) = HsForAllTy a b c (g d) + f (HsForAllTy a b c d e) = HsForAllTy a b c d (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) @@ -82,7 +82,7 @@ outHsType dflags = out dflags . dropHsDocTy makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c +makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d makeExplicit x = x makeExplicitL :: LHsType a -> LHsType a @@ -120,21 +120,21 @@ 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 _ _)) = ppSig dflags $ TypeSig [name] typ [] + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ [] f (SigD sig) = ppSig dflags sig f _ = [] ppExport _ _ = [] ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) +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 -> HsForAllTy Implicit a b c - HsForAllTy Qualified a b c -> HsForAllTy Implicit a b c + 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 _ _ = [] @@ -144,12 +144,12 @@ 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)) = TypeSig name (L l $ f sig) + addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs addContext (MinimalSig sig) = MinimalSig sig addContext _ = error "expected TypeSig" - f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d - f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) + 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))) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index ec3ea8d1..801f3138 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -212,7 +212,7 @@ 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 (L _ t) _)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -249,7 +249,7 @@ 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 (TypeSig lnames _ _) -> map unLoc lnames SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] @@ -293,7 +293,7 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of -- | 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 (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 ForD d -> ppFor loc (doc, fnArgsDoc) d unicode @@ -393,15 +393,15 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) arg_doc n = rDoc (Map.lookup n argDocs) do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + 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 a lctxt ltype) - = do_args n leader (HsForAllTy Implicit a lctxt ltype) - do_args n leader (HsForAllTy Implicit _ lctxt 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 @@ -521,7 +521,7 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ)) <- lsigs + | L _ (TypeSig lnames (L _ typ) _) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -895,9 +895,12 @@ 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 tvs ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] + where ctxt' = case extra of + Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt + Nothing -> ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name @@ -937,6 +940,10 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty _ HsWildcardTy _ = char '_' + +ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name + ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 85d2652a..49f835c8 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -587,7 +587,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 (L _ _) _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 0cb5ffb4..2c0a124a 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -43,11 +43,11 @@ 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 + 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 ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual @@ -132,13 +132,13 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Implicit _ lctxt ltype) + do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) | not (null (unLoc lctxt)) = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) @@ -416,7 +416,7 @@ 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 + | L _ (TypeSig lnames (L _ typ) _) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -461,7 +461,7 @@ ppClassDecl summary links instances fixities loc d 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 + | L _ (TypeSig lnames (L _ typ) _) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -474,12 +474,12 @@ ppClassDecl summary links instances fixities loc d subdocs minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | 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 @@ -850,9 +850,12 @@ 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 tvs ctxt ty) unicode qual +ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] + hsep [ppForAll expl tvs ctxt' unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] + where ctxt' = case extra of + Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt + Nothing -> ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _ @@ -898,6 +901,10 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty _ HsWildcardTy _ _ = char '_' + +ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name + ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html -- cgit v1.2.3