From 008e61d0c4b10713751c2a1de4958acc75367396 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 1 Jul 2016 11:50:08 +0200 Subject: GhcUtils: Changes for multi-pattern signatures --- haddock-api/src/Haddock/Backends/LaTeX.hs | 12 +++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 30 ++++++++++++-------------- haddock-api/src/Haddock/Convert.hs | 2 +- haddock-api/src/Haddock/GhcUtils.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 6 +++--- 5 files changed, 25 insertions(+), 27 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 85716f33..3b0c38c4 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -251,7 +251,7 @@ 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 (PatSynSig lnames _) -> map unLoc lnames ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n] _ -> error "declaration not supported by declNames" @@ -296,8 +296,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of 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 + SigD (PatSynSig lnames ty) -> + ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty DerivD _ -> empty @@ -355,14 +355,14 @@ ppFunSig loc doc docnames (L _ typ) unicode = where names = map getName docnames -ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName +ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsSigType DocName -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode +ppLPatSig _loc (doc, _argDocs) docnames ty unicode = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern" - , ppDocBinder name + , hsep $ punctuate comma $ map ppDocBinder docnames , dcolon unicode , ppLType unicode (hsSigType ty) ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index d32c6d1b..ed9fd964 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -44,18 +44,18 @@ 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 + 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 + SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames ty fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual - InstD _ -> noHtml - DerivD _ -> noHtml - _ -> error "declaration not supported by ppDecl" + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ -> noHtml + DerivD _ -> noHtml + _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> @@ -75,22 +75,20 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = pp_typ = ppLType unicode qual typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> LHsSigType DocName -> + [Located DocName] -> LHsSigType DocName -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual +ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual | summary = pref1 - | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) + | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) +++ docSection Nothing qual doc where pref1 = hsep [ keyword "pattern" - , ppBinder summary occname + , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames , dcolon unicode , ppLType unicode qual (hsSigType typ) ] - occname = nameOccName . getName $ name - ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> Splice -> Unicode -> Qualification -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5f3a1e9e..88cedc75 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -101,7 +101,7 @@ tyThingToLHsDecl t = case t of (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps) + allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3933f8e7..c8e5ea8b 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -104,7 +104,7 @@ sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name] sigNameNoLoc (TypeSig ns _) = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _) = [unLoc n] +sigNameNoLoc (PatSynSig ns _) = map unLoc ns sigNameNoLoc (SpecSig n _ _) = [unLoc n] sigNameNoLoc (InlineSig n _) = [unLoc n] sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index ab23ce3b..d786d0cc 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -470,10 +470,10 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty return (ClassOpSig is_default lnames' ltype') - PatSynSig lname sig_ty -> do - lname' <- renameL lname + PatSynSig lnames sig_ty -> do + lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig lname' sig_ty' + return $ PatSynSig lnames' sig_ty' FixSig (FixitySig lnames fixity) -> do lnames' <- mapM renameL lnames return $ FixSig (FixitySig lnames' fixity) -- cgit v1.2.3