From 32964567f8547e5d675be2cb58c952443f88f8bb Mon Sep 17 00:00:00 2001 From: mac-adder Date: Thu, 12 Oct 2017 14:12:06 +0200 Subject: [PATCH 1/8] Add better support for default signatures in class definitions --- .../src/Haddock/Backends/Xhtml/Decl.hs | 34 +++++++++++++------ .../src/Haddock/Backends/Xhtml/Layout.hs | 4 +++ haddock-api/src/Haddock/GhcUtils.hs | 10 ++++++ 3 files changed, 38 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 12e65716fd..d6abd33079 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -27,6 +27,7 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) +import Control.Applicative (liftA2) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe @@ -72,14 +73,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc mempty doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -226,7 +227,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc mempty doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -503,7 +504,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc mempty doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -551,17 +552,30 @@ 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 [name] (hsSigType typ) + methodBit = subMethods [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs + <+> subDefaults (maybeToList defSigs) + | L _ (ClassOpSig _ False lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name ] -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. + ppDefaultFunSig name' (typ', doc') = ppFunSig summary links loc + (keyword "default") doc' [name'] (hsSigType typ') [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | L _ (ClassOpSig _ True lnames typ) <- lsigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + , '$':'d':'m':nameStr <- [getOccString name] + ] + minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 76b57b3bc5..cedb376a05 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout ( subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -256,6 +257,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock + subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 805c537d12..492690d91a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,6 +17,7 @@ module Haddock.GhcUtils where +import Control.Applicative (liftA2) import Control.Arrow import Haddock.Types( DocNameI ) @@ -36,7 +37,9 @@ import VarSet ( VarSet, emptyVarSet ) import TyCoRep ( Type(..) ) import HsTypes (HsType(..)) +import Unique (deriveUnique, getKey) +import Haddock.Types (SetName(..)) moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -63,6 +66,13 @@ getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] +uniquifyClassSig :: (NamedThing name, SetName name) => Bool -> name -> name +uniquifyClassSig False = id +uniquifyClassSig _ = liftA2 setName (updateName . getName) id + where + updateName = liftA2 setNameUnique id $ + liftA2 deriveUnique id ((+1) . getKey) . nameUnique + -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. From 46fe9bb3aac0516d21896b7cba6aca2d42c19fa2 Mon Sep 17 00:00:00 2001 From: mac-adder Date: Fri, 13 Oct 2017 10:31:41 +0200 Subject: [PATCH 2/8] Remove unnecessary import --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d6abd33079..23b982d223 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -27,7 +27,6 @@ import Haddock.GhcUtils import Haddock.Types import Haddock.Doc (combineDocumentation) -import Control.Applicative (liftA2) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe From 0dca7e577ef2cdfa7cd5886bc7e66eea5a2e0d4c Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 5 Sep 2018 04:34:36 -0700 Subject: [PATCH 3/8] Fix filtering to let through default methods... ...when the other method is let through. --- haddock-api/src/Haddock/Convert.hs | 20 ++++++++++++-------- haddock-api/src/Haddock/Utils.hs | 13 ++++++++++--- 2 files changed, 22 insertions(+), 11 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a645bb8245..ab01b64126 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -95,11 +95,12 @@ tyThingToLHsDecl t = case t of atTyClDecls = map extractAtItem (classATItems cl) (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) + vs = tyConVisibleTyVars (classTyCon cl) in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) + , tcdTyVars = synifyTyVars vs , tcdFixity = Prefix , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ @@ -107,7 +108,7 @@ tyThingToLHsDecl t = case t of , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : [ noLoc tcdSig | clsOp <- classOpItems cl - , tcdSig <- synifyTcIdSig DeleteTopLevelQuantification clsOp ] + , tcdSig <- synifyTcIdSig vs clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: , tcdATs = atFamDecls @@ -387,11 +388,14 @@ synifyIdSig s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs (varType -- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going -- to contain the synified 'ClassOpSig' as well (when appropriate) a default -- 'ClassOpSig'. -synifyTcIdSig :: SynifyTypeState -> ClassOpItem -> [Sig GhcRn] -synifyTcIdSig s (i, dm) = - [ ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) ] ++ - [ ClassOpSig noExt True [noLoc dn] (synifySigType s dt) +synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] +synifyTcIdSig vs (i, dm) = + [ ClassOpSig noExt False [synifyName i] (mainSig (varType i)) ] ++ + [ ClassOpSig noExt True [noLoc dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] + where + mainSig t = synifySigType DeleteTopLevelQuantification vs t + defSig t = synifySigType ImplicitizeForAll vs t synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType []) @@ -461,10 +465,10 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn +synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? -synifySigType s ty = mkEmptyImplicitBndrs (synifyType s [] ty) +synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index c2cdddf746..cbadc22d89 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils @@ -165,8 +166,8 @@ restrictTo names (L loc decl) = L loc $ case decl of TyClD x d | isDataDecl d -> TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) TyClD x d | isClassDecl d -> - TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d) + , tcdATs = restrictATs names (tcdATs d) }) _ -> decl restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn @@ -204,7 +205,13 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] keep _ = Nothing restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) +restrictDecls names = mapMaybe (filterLSigNames func) + where func n | n `elem` names = True + + -- let through default method iff method is let through + | '$':'d':'m':strN <- getOccString n + , strN `elem` map getOccString names = True + | otherwise = False restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] From 4ea6d9e3f1fcd9bad6ff22c42cd5ee4d57c99386 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 5 Sep 2018 06:07:51 -0700 Subject: [PATCH 4/8] Render default associated types There is still no plan for documenting these though. --- .../src/Haddock/Backends/Xhtml/Decl.hs | 94 ++++++++++++------- 1 file changed, 62 insertions(+), 32 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 23b982d223..4baf2e0ff8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -33,6 +33,7 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula @@ -524,8 +525,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs + , tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection Nothing pkg qual d @@ -540,41 +542,68 @@ ppClassDecl summary links instances fixities loc d subdocs -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - nm = tcdName decl - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - - methodBit = subMethods [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) - subfixs splice unicode pkg qual - <+> subDefaults (maybeToList defSigs) - | L _ (ClassOpSig _ False lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = filter ((== name) . fst) fixities - defSigs = ppDefaultFunSig name <$> lookupDM name - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. - - ppDefaultFunSig name' (typ', doc') = ppFunSig summary links loc - (keyword "default") doc' [name'] (hsSigType typ') [] splice unicode pkg qual + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = ppDefaultAssocTy name <$> lookupDAT name + ] + + -- Default associated types + ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl + splice unicode pkg qual + where + synDecl = SynDecl { tcdSExt = noExt + , tcdLName = noLoc n + , tcdTyVars = vs + , tcdFixity = GHC.Prefix + , tcdRhs = t } + + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ, doc)) + | L _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }) <- atsDefs + , let doc = noDocForDecl -- TODO: get docs for associated type defaults + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] (hsSigType t) [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList - [ (nameStr, (typ, doc)) - | L _ (ClassOpSig _ True lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - , '$':'d':'m':nameStr <- [getOccString name] - ] + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + , '$':'d':'m':nameStr <- [getOccString name] + ] + -- Minimal complete definition minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == @@ -583,7 +612,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -598,6 +627,7 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) + -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual From 16cc5fa8cf935b687a63c85e5408a0c03cb07b2d Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 5 Sep 2018 08:15:35 -0700 Subject: [PATCH 5/8] Patch LaTeX backend support for class methods A while back, class methods changed from 'TypeSig' -> 'ClassOpSig'. I also took the opportunity to at least render default signatures. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 53 +++++++++++++---------- haddock-api/src/Haddock/Types.hs | 3 ++ 2 files changed, 33 insertions(+), 23 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index ea233ab764..97c8ccfc07 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -24,7 +24,7 @@ import qualified Pretty import GHC import OccName -import Name ( nameOccName ) +import Name ( getOccString, nameOccName, tidyNameOcc ) import RdrName ( rdrNameOcc ) import FastString ( unpackFS ) import Outputable ( panic) @@ -292,7 +292,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -304,7 +304,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig Nothing doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -411,17 +411,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames + lead = maybe id (<+>) leader -- | Pretty-print a pattern synonym ppLPatSig :: DocForDecl DocName -- ^ documentation @@ -430,15 +436,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigType ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. @@ -584,6 +582,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated types, associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -609,13 +608,21 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig _ lnames typ) <- lsigs + vcat [ ppFunSig leader doc names (hsSigType typ) unicode + | L _ (ClassOpSig _ is_def 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 - -- there are different subdocs for different names in a single - -- type signature? + names = map (cleanName . unLoc) lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. + + -- Get rid of the ugly '$dm' prefix on default method names + cleanName n + | isDefaultMethodOcc (occName n) + , '$':'d':'m':occStr <- getOccString n + = setName (tidyNameOcc (getName n) (mkOccName varName occStr)) n + | otherwise = n instancesBit = ppDocInstances unicode instances diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index ed8a7ff1d7..68e833dc4e 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -322,6 +322,9 @@ instance SetName DocName where setName name' (Undocumented _) = Undocumented name' +instance HasOccName DocName where + + occName = occName . getName ----------------------------------------------------------------------------- -- * Instances From 2e2351d3dd8c52e5ec7367594c98550cfd439869 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 5 Sep 2018 08:18:53 -0700 Subject: [PATCH 6/8] Add test cases for default methods sigs --- html-test/src/DefaultAssociatedTypes.hs | 14 ++++++++++++++ html-test/src/DefaultSignatures.hs | 19 +++++++++++++++++++ .../DefaultSignatures/DefaultSignatures.hs | 19 +++++++++++++++++++ 3 files changed, 52 insertions(+) create mode 100644 html-test/src/DefaultAssociatedTypes.hs create mode 100644 html-test/src/DefaultSignatures.hs create mode 100644 latex-test/src/DefaultSignatures/DefaultSignatures.hs diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs new file mode 100644 index 0000000000..6ad197d399 --- /dev/null +++ b/html-test/src/DefaultAssociatedTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DefaultSignatures, TypeFamilies #-} + +module DefaultAssociatedTypes where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Doc for Qux + type Qux a :: * + + -- | Doc for default Qux + type Qux a = [a] diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs new file mode 100644 index 0000000000..52d68a9609 --- /dev/null +++ b/html-test/src/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read diff --git a/latex-test/src/DefaultSignatures/DefaultSignatures.hs b/latex-test/src/DefaultSignatures/DefaultSignatures.hs new file mode 100644 index 0000000000..52d68a9609 --- /dev/null +++ b/latex-test/src/DefaultSignatures/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read From ad12cd294f01b2f92dfd290915cd6fd7bf611a7d Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 10 Sep 2018 19:26:21 -0700 Subject: [PATCH 7/8] Accept default signature test case outputs --- html-test/ref/DefaultAssociatedTypes.html | 158 +++++++++++++++ html-test/ref/DefaultSignatures.html | 182 ++++++++++++++++++ .../DefaultSignatures/DefaultSignatures.tex | 48 +++++ latex-test/ref/DefaultSignatures/haddock.sty | 57 ++++++ latex-test/ref/DefaultSignatures/main.tex | 11 ++ 5 files changed, 456 insertions(+) create mode 100644 html-test/ref/DefaultAssociatedTypes.html create mode 100644 html-test/ref/DefaultSignatures.html create mode 100644 latex-test/ref/DefaultSignatures/DefaultSignatures.tex create mode 100644 latex-test/ref/DefaultSignatures/haddock.sty create mode 100644 latex-test/ref/DefaultSignatures/main.tex diff --git a/html-test/ref/DefaultAssociatedTypes.html b/html-test/ref/DefaultAssociatedTypes.html new file mode 100644 index 0000000000..8921a50974 --- /dev/null +++ b/html-test/ref/DefaultAssociatedTypes.html @@ -0,0 +1,158 @@ +DefaultAssociatedTypes
Safe HaskellSafe

DefaultAssociatedTypes

Synopsis

Documentation

class Foo a where #

Documentation for Foo.

Associated Types

type Qux a #

Doc for Qux

type Qux a = [a] #

Methods

bar :: a -> String #

Documentation for bar and baz.

baz :: a -> String #

Documentation for bar and baz.

\ No newline at end of file diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 index 0000000000..061876b4d8 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,182 @@ +DefaultSignatures
Safe HaskellSafe

DefaultSignatures

Synopsis

Documentation

class Foo a where #

Documentation for Foo.

Minimal complete definition

baz

Methods

bar :: a -> String #

Documentation for bar and baz.

default bar :: Show a => a -> String #

baz :: a -> String #

Documentation for bar and baz.

baz' :: String -> a #

Documentation for baz'.

default baz' :: Read a => String -> a #

\ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex new file mode 100644 index 0000000000..63ec7beb16 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -0,0 +1,48 @@ +\haddockmoduleheading{DefaultSignatures} +\label{module:DefaultSignatures} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module DefaultSignatures ( + Foo(baz', baz, bar) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +class\ Foo\ a\ where +\end{tabular}]\haddockbegindoc +Documentation for Foo.\par + +\haddockpremethods{}\emph{Methods} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +bar\ ::\ a\ ->\ String +\end{tabular}]\haddockbegindoc +Documentation for bar and baz.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +baz\ ::\ a\ ->\ String +\end{tabular}]\haddockbegindoc +Documentation for bar and baz.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +baz'\ ::\ String\ ->\ a +\end{tabular}]\haddockbegindoc +Documentation for baz'.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a +\end{tabular}] +\end{haddockdesc} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty new file mode 100644 index 0000000000..6e031a98b6 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex new file mode 100644 index 0000000000..d30eb00840 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{DefaultSignatures} +\end{document} \ No newline at end of file From 76176f5ebe91a886b72bcf87ff0d05b116a85e77 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 10 Sep 2018 20:21:49 -0700 Subject: [PATCH 8/8] Address review comments * remove unused (and buggy) function * 'mempty' -> 'noHtml' --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 ++++---- haddock-api/src/Haddock/GhcUtils.hs | 10 ---------- 2 files changed, 4 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 4baf2e0ff8..f6940ccce4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -73,7 +73,7 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc mempty doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> @@ -227,7 +227,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc mempty doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -504,7 +504,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc mempty doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -577,7 +577,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Methods methodBit = subMethods - [ ppFunSig summary links loc mempty doc [name] (hsSigType typ) + [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ) subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 492690d91a..805c537d12 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,7 +17,6 @@ module Haddock.GhcUtils where -import Control.Applicative (liftA2) import Control.Arrow import Haddock.Types( DocNameI ) @@ -37,9 +36,7 @@ import VarSet ( VarSet, emptyVarSet ) import TyCoRep ( Type(..) ) import HsTypes (HsType(..)) -import Unique (deriveUnique, getKey) -import Haddock.Types (SetName(..)) moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -66,13 +63,6 @@ getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -uniquifyClassSig :: (NamedThing name, SetName name) => Bool -> name -> name -uniquifyClassSig False = id -uniquifyClassSig _ = liftA2 setName (updateName . getName) id - where - updateName = liftA2 setNameUnique id $ - liftA2 deriveUnique id ((+1) . getKey) . nameUnique - -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap.