From 17970e6b6aa22962c498ce02ead8dbadad31a733 Mon Sep 17 00:00:00 2001
From: Niklas Haas <git@nand.wakku.to>
Date: Sat, 8 Mar 2014 09:42:00 +0100
Subject: [PATCH] Render fixity information
Affects functions, type synonyms, type families, class names, data type
names, constructors, data families, associated TFs/DFs, type synonyms,
pattern synonyms and everything else I could think of.
---
html-test/ref/Bug8.html | 6 +-
html-test/ref/Operators.html | 379 ++++++++++++++++++++++++++++
html-test/src/Operators.hs | 56 ++++
src/Haddock/Backends/Hoogle.hs | 2 +-
src/Haddock/Backends/LaTeX.hs | 11 +-
src/Haddock/Backends/Xhtml.hs | 10 +-
src/Haddock/Backends/Xhtml/Decl.hs | 175 ++++++++-----
src/Haddock/Backends/Xhtml/Utils.hs | 17 +-
src/Haddock/Interface/Create.hs | 53 ++--
src/Haddock/Interface/Rename.hs | 10 +-
src/Haddock/Types.hs | 6 +
11 files changed, 621 insertions(+), 104 deletions(-)
create mode 100644 html-test/ref/Operators.html
create mode 100644 html-test/src/Operators.hs
diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html
index f3845cb248..7e5b5feeb2 100644
--- a/html-test/ref/Bug8.html
+++ b/html-test/ref/Bug8.html
@@ -84,7 +84,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug8.html");};
></div
><div class="top"
><p class="src"
- ><a name="v:-45--45--62-" class="def"
+ >infix 9 --><br
+ /><a name="v:-45--45--62-" class="def"
>(-->)</a
> :: t -> t1 -> <a href=""
>Typ</a
@@ -92,7 +93,8 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug8.html");};
></div
><div class="top"
><p class="src"
- ><a name="v:-45--45--45--62-" class="def"
+ >infix 9 ---><br
+ /><a name="v:-45--45--45--62-" class="def"
>(--->)</a
> :: [a] -> <a href=""
>Typ</a
diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html
new file mode 100644
index 0000000000..89ebbbbfd4
--- /dev/null
+++ b/html-test/ref/Operators.html
@@ -0,0 +1,379 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >Operators</title
+ ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"
+ /><script src="haddock-util.js" type="text/javascript"
+ ></script
+ ><script type="text/javascript"
+ >//<![CDATA[
+window.onload = function () {pageLoad();setSynopsis("mini_Operators.html");};
+//]]>
+</script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="index.html"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="doc-index.html"
+ >Index</a
+ ></li
+ ></ul
+ ><p class="caption empty"
+ > </p
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe-Inferred</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Operators</p
+ ></div
+ ><div id="description"
+ ><p class="caption"
+ >Description</p
+ ><div class="doc"
+ ><p
+ >Test operators with or without fixity declarations</p
+ ></div
+ ></div
+ ><div id="synopsis"
+ ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"
+ >Synopsis</p
+ ><ul id="section.syn" class="hide" onclick="toggleSection('syn')"
+ ><li class="src short"
+ ><a href="#v:-43--45-"
+ >(+-)</a
+ > :: a -> a -> a</li
+ ><li class="src short"
+ ><a href="#v:-42--47-"
+ >(*/)</a
+ > :: a -> a -> a</li
+ ><li class="src short"
+ ><a href="#v:foo"
+ >foo</a
+ > :: a -> a -> a</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > <a href="#t:Foo"
+ >Foo</a
+ ><ul class="subs"
+ ><li
+ >= <a href="Operators.html#t:Foo"
+ >Foo</a
+ > <a href="#v:Bar"
+ >`Bar`</a
+ > <a href="Operators.html#t:Foo"
+ >Foo</a
+ ></li
+ ><li
+ >| <a href="Operators.html#t:Foo"
+ >Foo</a
+ > <a href="#v::-45-"
+ >:-</a
+ > <a href="Operators.html#t:Foo"
+ >Foo</a
+ ></li
+ ></ul
+ ></li
+ ><li class="src short"
+ >pattern <a href="#v::-43-"
+ >(:+)</a
+ > t t :: [t]</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data</span
+ > a <a href="#t:-60--45--62-"
+ ><-></a
+ > b <span class="keyword"
+ >where</span
+ ><ul class="subs"
+ ><li
+ ><a href="#v::-60--45--62-"
+ >(:<->)</a
+ > :: a -> b -> a <a href="Operators.html#t:-60--45--62-"
+ ><-></a
+ > b</li
+ ></ul
+ ></li
+ ><li class="src short"
+ ><span class="keyword"
+ >type family</span
+ > a <a href="#t:-43--43-"
+ >++</a
+ > b</li
+ ><li class="src short"
+ ><span class="keyword"
+ >data family</span
+ > a <a href="#t:-42--42-"
+ >**</a
+ > b</li
+ ><li class="src short"
+ ><span class="keyword"
+ >class</span
+ > a <a href="#t:-62--60--62-"
+ >><></a
+ > b <span class="keyword"
+ >where</span
+ ><ul class="subs"
+ ><li
+ ><span class="keyword"
+ >type</span
+ > a <a href="#t:-60--62--60-"
+ ><><</a
+ > b :: *</li
+ ><li
+ ><span class="keyword"
+ >data</span
+ > a <a href="#t:-62--60--60-"
+ >><<</a
+ > b</li
+ ><li
+ ><a href="#v:-62--62--60-"
+ >(>><)</a
+ > :: a -> b -> ()</li
+ ></ul
+ ></li
+ ><li class="src short"
+ ><span class="keyword"
+ >type</span
+ > <a href="#t:-62--45--60-"
+ >(>-<)</a
+ > a b = a <a href="Operators.html#t:-60--45--62-"
+ ><-></a
+ > b</li
+ ></ul
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:-43--45-" class="def"
+ >(+-)</a
+ > :: a -> a -> a</p
+ ><div class="doc"
+ ><p
+ >Operator with no fixity</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infixr 7 */<br
+ /><a name="v:-42--47-" class="def"
+ >(*/)</a
+ > :: a -> a -> a</p
+ ><div class="doc"
+ ><p
+ >Operator with infixr 7</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infixl 3 `foo`<br
+ /><a name="v:foo" class="def"
+ >foo</a
+ > :: a -> a -> a</p
+ ><div class="doc"
+ ><p
+ >Named function with infixl 3</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >data</span
+ > <a name="t:Foo" class="def"
+ >Foo</a
+ ></p
+ ><div class="doc"
+ ><p
+ >Data type with operator constructors</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ >infixl 3 `Bar`<br
+ /><a href="Operators.html#t:Foo"
+ >Foo</a
+ > <a name="v:Bar" class="def"
+ >`Bar`</a
+ > <a href="Operators.html#t:Foo"
+ >Foo</a
+ ></td
+ ><td class="doc"
+ ><p
+ >Has infixl 3</p
+ ></td
+ ></tr
+ ><tr
+ ><td class="src"
+ >infixr 5 :-<br
+ /><a href="Operators.html#t:Foo"
+ >Foo</a
+ > <a name="v::-45-" class="def"
+ >:-</a
+ > <a href="Operators.html#t:Foo"
+ >Foo</a
+ ></td
+ ><td class="doc"
+ ><p
+ >Has infixr 5</p
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infixr 3 :+<br
+ />pattern <a name="v::-43-" class="def"
+ >(:+)</a
+ > t t :: [t]</p
+ ><div class="doc"
+ ><p
+ >Pattern synonym, infixr 3</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infixl 6 <-><br
+ /><span class="keyword"
+ >data</span
+ > a <a name="t:-60--45--62-" class="def"
+ ><-></a
+ > b <span class="keyword"
+ >where</span
+ ></p
+ ><div class="doc"
+ ><p
+ >Type name, infixl 6 and GADT constructor</p
+ ></div
+ ><div class="subs constructors"
+ ><p class="caption"
+ >Constructors</p
+ ><table
+ ><tr
+ ><td class="src"
+ >infixr 6 :<-><br
+ /><a name="v::-60--45--62-" class="def"
+ >(:<->)</a
+ > :: a -> b -> a <a href="Operators.html#t:-60--45--62-"
+ ><-></a
+ > b</td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infix 3 ++<br
+ /><span class="keyword"
+ >type family</span
+ > a <a name="t:-43--43-" class="def"
+ >++</a
+ > b</p
+ ><div class="doc"
+ ><p
+ >Type family with fixity</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infix 9 **<br
+ /><span class="keyword"
+ >data family</span
+ > a <a name="t:-42--42-" class="def"
+ >**</a
+ > b</p
+ ><div class="doc"
+ ><p
+ >Data family with fixity</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infixr 1 ><><br
+ /><span class="keyword"
+ >class</span
+ > a <a name="t:-62--60--62-" class="def"
+ >><></a
+ > b <span class="keyword"
+ >where</span
+ ></p
+ ><div class="doc"
+ ><p
+ >Class with fixity, including associated types</p
+ ></div
+ ><div class="subs associated-types"
+ ><p class="caption"
+ >Associated Types</p
+ ><p class="src"
+ >infixl 2 <><<br
+ /><span class="keyword"
+ >type</span
+ > a <a name="t:-60--62--60-" class="def"
+ ><><</a
+ > b :: *</p
+ ><p class="src"
+ >infixl 3 ><<<br
+ /><span class="keyword"
+ >data</span
+ > a <a name="t:-62--60--60-" class="def"
+ >><<</a
+ > b</p
+ ></div
+ ><div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ >infixr 4 >><<br
+ /><a name="v:-62--62--60-" class="def"
+ >(>><)</a
+ > :: a -> b -> ()</p
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ >infixl 6 >-<<br
+ /><span class="keyword"
+ >type</span
+ > <a name="t:-62--45--60-" class="def"
+ >(>-<)</a
+ > a b = a <a href="Operators.html#t:-60--45--62-"
+ ><-></a
+ > b</p
+ ><div class="doc"
+ ><p
+ >Type synonym with fixity</p
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ><p
+ >Produced by <a href="http://www.haskell.org/haddock/"
+ >Haddock</a
+ > version 2.14.0</p
+ ></div
+ ></body
+ ></html
+>
diff --git a/html-test/src/Operators.hs b/html-test/src/Operators.hs
new file mode 100644
index 0000000000..a2e30c1890
--- /dev/null
+++ b/html-test/src/Operators.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs #-}
+-- | Test operators with or without fixity declarations
+module Operators where
+
+-- | Operator with no fixity
+(+-) :: a -> a -> a
+a +- _ = a
+
+-- | Operator with infixr 7
+(*/) :: a -> a -> a
+_ */ b = b
+infixr 7 */
+
+-- | Named function with infixl 3
+foo :: a -> a -> a
+foo a _ = a
+infixl 3 `foo`
+
+-- | Data type with operator constructors
+data Foo
+ = Foo `Bar` Foo -- ^ Has infixl 3
+ | Foo :- Foo -- ^ Has infixr 5
+infixr 5 :-
+infixl 3 `Bar`
+
+-- | Pattern synonym, infixr 3
+pattern (:+) a b <- [a,b]
+infixr 3 :+
+
+-- | Type name, infixl 6 and GADT constructor
+data (a <-> b) where
+ (:<->) :: a -> b -> a <-> b
+infixl 6 <->
+infixr 6 :<->
+
+-- | Type family with fixity
+type family a ++ b
+infix 3 ++
+
+-- | Data family with fixity
+data family a ** b
+infix 9 **
+
+-- | Class with fixity, including associated types
+class a ><> b where
+ type a <>< b :: *
+ data a ><< b
+ (>><) :: a -> b -> ()
+infixr 1 ><>
+infixl 2 <><
+infixl 3 ><<
+infixr 4 >><
+
+-- | Type synonym with fixity
+type (a >-< b) = a <-> b
+infixl 6 >-<
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 1f098d6d1f..dbce787f9f 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -110,7 +110,7 @@ operator x = x
-- How to print each export
ppExport :: DynFlags -> ExportItem Name -> [String]
-ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
+ppExport dflags (ExportDecl decl dc subdocs _ _) = ppDocumentation dflags (fst dc) ++ f (unL decl)
where
f (TyClD d@DataDecl{}) = ppData dflags d subdocs
f (TyClD d@SynDecl{}) = ppSynonym dflags d
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 24e8b7c83a..e6108ab631 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -177,7 +177,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
exportListItem :: ExportItem DocName -> LaTeX
-exportListItem (ExportDecl decl _doc subdocs _insts)
+exportListItem (ExportDecl decl _doc subdocs _insts _fixities)
= sep (punctuate comma . map ppDocBinder $ declNames decl) <>
case subdocs of
[] -> empty
@@ -212,7 +212,7 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t))))
- (Documentation Nothing Nothing, argDocs) _ _)
+ (Documentation Nothing Nothing, argDocs) _ _ _)
| Map.null argDocs = Just (map unLoc lnames, t)
isSimpleSig _ = Nothing
@@ -225,8 +225,8 @@ isExportModule _ = Nothing
processExport :: ExportItem DocName -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts)
- = ppDecl decl doc insts subdocs
+processExport (ExportDecl decl doc subdocs insts fixities)
+ = ppDecl decl doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
processExport (ExportNoDecl y subs)
@@ -279,9 +279,10 @@ ppDecl :: LHsDecl DocName
-> DocForDecl DocName
-> [DocInstance DocName]
-> [(DocName, DocForDecl DocName)]
+ -> [(DocName, Fixity)]
-> LaTeX
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
+ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
TyClD d@(DataDecl {})
-> ppDataDecl instances subdocs loc (Just doc) d unicode
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index bdd1afdcf0..4eda68f609 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -533,7 +533,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning
+ has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _ _) = isJust mDoc || isJust mWarning
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -578,7 +578,7 @@ miniSynopsis mdl iface unicode qual =
processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
-> [Html]
-processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts) =
+processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts _fixities) =
((divTopDecl <<).(declElem <<)) <$> case decl0 of
TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
(FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
@@ -648,11 +648,11 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Qualification
-> ExportItem DocName -> Maybe Html
-processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _) = Nothing -- Hide empty instances
+processExport _ _ _ _ (ExportDecl (L _ (InstD _)) _ _ _ _) = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts)
- = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual
+processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities)
+ = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 9e72d4ad25..20db5df1eb 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -37,50 +37,53 @@ import GHC
import Name
-ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
- DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
- Bool -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances loc mbDoc d unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty unicode qual
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs unicode qual = case decl of
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities unicode qual
SigD (PatSynSig lname args ty prov req) ->
- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities unicode qual
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsType DocName -> Bool -> Qualification -> Html
-ppLFunSig summary links loc doc lnames lty unicode qual =
- ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) unicode qual
+ [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
+ Bool -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities unicode qual =
+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities unicode qual
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [DocName] -> HsType DocName -> Bool -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ unicode qual =
- ppSigLike summary links loc mempty doc docnames (typ, pp_typ) unicode qual
+ [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
+ Bool -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities unicode qual =
+ ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) unicode qual
where
pp_typ = ppType unicode qual typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
Located DocName ->
HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
- LHsContext DocName -> LHsContext DocName ->
+ LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
Bool -> Qualification -> Html
-ppLPatSig summary links loc doc lname args typ prov req unicode qual =
- ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode qual
+ppLPatSig summary links loc doc lname args typ prov req fixities unicode qual =
+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) fixities unicode qual
ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
DocName ->
HsPatSynDetails (HsType DocName) -> HsType DocName ->
- HsContext DocName -> HsContext DocName ->
+ HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
Bool -> Qualification -> Html
-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qual
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities unicode qual
| summary = pref1
- | otherwise = topDeclElem links loc [docname] pref1 +++ docSection qual doc
+ | otherwise = topDeclElem links loc [docname] (ppFixities fixities qual <=> pref1)
+ +++ docSection qual doc
where
pref1 = hsep [ toHtml "pattern"
, pp_cxt prov
@@ -99,16 +102,20 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qua
occname = nameOccName . getName $ docname
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
- [DocName] -> (HsType DocName, Html) -> Bool -> Qualification -> Html
-ppSigLike summary links loc leader doc docnames (typ, pp_typ) unicode qual =
+ [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
+ Bool -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) unicode qual =
ppTypeOrFunSig summary links loc docnames typ doc
- ( leader <+> ppTypeSig summary occnames pp_typ unicode
- , concatHtml . punctuate comma $ map (ppBinder False) occnames
+ ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
+ , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
unicode qual
where
occnames = map (nameOccName . getName) docnames
+ addFixities html
+ | summary = html
+ | otherwise = ppFixities fixities qual <=> html
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
@@ -144,6 +151,16 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
do_args n leader t
= [(leader <+> ppType unicode qual t, argDoc n, [])]
+ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
+ppFixities fs qual = vcat $ map ppFix fs
+ where
+ ppFix (n, Fixity p d) = toHtml (ppDir d) <+> toHtml (show p)
+ <+> ppDocName qual Infix False n
+
+ ppDir InfixR = "infixr"
+ ppDir InfixL = "infixl"
+ ppDir InfixN = "infix"
+
ppTyVars :: LHsTyVarBndrs DocName -> [Html]
ppTyVars tvs = map ppTyName (tyvarNames tvs)
@@ -154,25 +171,28 @@ tyvarNames = map getName . hsLTyVarNames
ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
- -> ForeignDecl DocName -> Bool -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode qual
- = ppFunSig summary links loc doc [name] typ unicode qual
-ppFor _ _ _ _ _ _ _ = error "ppFor"
+ -> ForeignDecl DocName -> [(DocName, Fixity)] -> Bool -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities unicode qual
+ = ppFunSig summary links loc doc [name] typ fixities unicode qual
+ppFor _ _ _ _ _ _ _ _ = error "ppFor"
-- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool
-> Qualification -> Html
-ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdRhs = ltype })
+ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype })
unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
- (full, hdr, spaceHtml +++ equals) unicode qual
+ (fixs <=> full, fixs <=> hdr, spaceHtml +++ equals) unicode qual
where
hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
full = hdr <+> equals <+> ppLType unicode qual ltype
occ = nameOccName . getName $ name
-ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+ fixs
+ | summary = noHtml
+ | otherwise = ppFixities fixities qual
+ppTySyn _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
@@ -212,9 +232,10 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
Nothing -> noHtml
)
-ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocName -> Bool -> Qualification -> Html
-ppTyFam summary associated links instances loc doc decl unicode qual
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
+ [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
+ FamilyDecl DocName -> Bool -> Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl unicode qual
| summary = ppTyFamHeader True associated decl unicode qual
| otherwise = header_ +++ docSection qual doc +++ instancesBit
@@ -222,7 +243,8 @@ ppTyFam summary associated links instances loc doc decl unicode qual
where
docname = unLoc $ fdLName decl
- header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode qual)
+ header_ = topDeclElem links loc [docname] $
+ ppFixities fixities qual <=> ppTyFamHeader summary associated decl unicode qual
instancesBit
| FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
@@ -244,10 +266,10 @@ ppTyFam summary associated links instances loc doc decl unicode qual
--------------------------------------------------------------------------------
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName -> Bool
- -> Qualification -> Html
-ppAssocType summ links doc (L loc decl) unicode qual =
- ppTyFam summ True links [] loc (fst doc) decl unicode qual
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
+ -> [(DocName, Fixity)] -> Bool -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities unicode qual =
+ ppTyFam summ True links [] fixities loc (fst doc) decl unicode qual
--------------------------------------------------------------------------------
@@ -363,12 +385,12 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where")
+++ shortSubDecls
(
- [ ppAssocType summary links doc at unicode qual | at <- ats
+ [ ppAssocType summary links doc at [] unicode qual | at <- ats
, let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-- ToDo: add associated type defaults
- [ ppFunSig summary links loc doc names typ unicode qual
+ [ ppFunSig summary links loc doc names typ [] unicode qual
| L _ (TypeSig lnames (L _ typ)) <- sigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
@@ -383,10 +405,11 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor
-ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan
- -> Documentation DocName -> [(DocName, DocForDecl DocName)]
- -> TyClDecl DocName -> Bool -> Qualification -> Html
-ppClassDecl summary links instances loc d subdocs
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> SrcSpan -> Documentation DocName
+ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
+ -> Bool -> Qualification -> Html
+ppClassDecl summary links instances fixities loc d subdocs
decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
, tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual
| summary = ppShortClassDecl summary links decl loc subdocs unicode qual
@@ -394,21 +417,29 @@ ppClassDecl summary links instances loc d subdocs
+++ atBit +++ methodBit +++ instancesBit
where
classheader
- | null lsigs = topDeclElem links loc [nm] (hdr unicode qual)
- | otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where")
+ | null lsigs = topDeclElem links loc [nm] (fixs <=> hdr unicode qual)
+ | otherwise = topDeclElem links loc [nm] (fixs <=> hdr unicode qual <+> keyword "where")
+
+ -- 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 unicode qual
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs unicode qual
| at <- ats
- , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]
+ , 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 doc names typ unicode qual
+ methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs unicode qual
| L _ (TypeSig lnames (L _ typ)) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
+ subfixs = [ f | n <- names
+ , f@(n',_) <- fixities
+ , n == n' ]
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
@@ -416,7 +447,7 @@ ppClassDecl summary links instances loc d subdocs
instancesBit = ppInstances instances nm unicode qual
-ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+ppClassDecl _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Qualification -> Html
@@ -471,11 +502,11 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
resTy = (con_res . unLoc . head) cons
-ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool ->
Qualification -> Html
-ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl unicode qual
| summary = ppShortDataDecl summary False dataDecl unicode qual
| otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
@@ -485,8 +516,10 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (con_res . unLoc . head) cons
- header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual
- <+> whereBit)
+ header_ = topDeclElem links loc [docname] (fix
+ <=> ppDataHeader summary dataDecl unicode qual <+> whereBit)
+
+ fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
whereBit
| null cons = noHtml
@@ -495,7 +528,10 @@ ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual
_ -> noHtml
constrBit = subConstructors qual
- (map (ppSideBySideConstr subdocs unicode qual) cons)
+ [ ppSideBySideConstr subdocs subfixs unicode qual c
+ | c <- cons
+ , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities
+ ]
instancesBit = ppInstances instances docname unicode qual
@@ -568,20 +604,20 @@ ppConstrHdr forall_ tvs ctxt unicode qual
Implicit -> noHtml
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> Qualification
- -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
+ -> Bool -> Qualification -> LConDecl DocName -> SubDecl
+ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
where
decl = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- hsep ((header_ unicode qual +++ ppBinder False occ)
+ hsep ((header_ +++ ppBinder False occ)
: map (ppLParendType unicode qual) args)
- RecCon _ -> header_ unicode qual +++ ppBinder False occ
+ RecCon _ -> header_ +++ ppBinder False occ
InfixCon arg1 arg2 ->
- hsep [header_ unicode qual +++ ppLParendType unicode qual arg1,
+ hsep [header_ +++ ppLParendType unicode qual arg1,
ppBinderInfix False occ,
ppLParendType unicode qual arg2]
@@ -599,12 +635,13 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
doRecordFields fields = subFields qual
(map (ppSideBySideField subdocs unicode qual) fields)
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
- doGADTCon args resTy =
+ doGADTCon args resTy = fixity <=>
ppBinder False occ <+> dcolon unicode
<+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
- header_ = ppConstrHdr forall_ tyVars context
+ fixity = ppFixities fixities qual
+ header_ = fixity <=> ppConstrHdr forall_ tyVars context unicode qual
occ = nameOccName . getName . unLoc . con_name $ con
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
index 232e18ccba..cbcbbd6da8 100644
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/src/Haddock/Backends/Xhtml/Utils.hs
@@ -17,13 +17,13 @@ module Haddock.Backends.Xhtml.Utils (
spliceURL,
groupId,
- (<+>), char,
+ (<+>), (<=>), char,
keyword, punctuate,
braces, brackets, pabrackets, parens, parenList, ubxParenList,
arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
- hsep,
+ hsep, vcat,
collapseSection, collapseToggle, collapseControl,
) where
@@ -100,6 +100,11 @@ hsep :: [Html] -> Html
hsep [] = noHtml
hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+-- | Concatenate a series of 'Html' values vertically, with linebreaks in between.
+vcat :: [Html] -> Html
+vcat [] = noHtml
+vcat htmls = foldr1 (\a b -> a+++br+++b) htmls
+
infixr 8 <+>
(<+>) :: Html -> Html -> Html
@@ -107,6 +112,14 @@ a <+> b = a +++ sep +++ b
where
sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " "
+-- | Join two 'Html' values together with a linebreak in between.
+-- Has 'noHtml' as left identity.
+infixr 8 <=>
+(<=>) :: Html -> Html -> Html
+a <=> b = a +++ sep +++ b
+ where
+ sep = if isNoHtml a then noHtml else br
+
keyword :: String -> Html
keyword s = thespan ! [theclass "keyword"] << toHtml s
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f3658a12c4..37d0fe7dbd 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -81,6 +81,7 @@ createInterface tm flags modMap instIfaceMap = do
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
+ fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
++ map getName fam_instances
@@ -97,7 +98,7 @@ createInterface tm flags modMap instIfaceMap = do
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps exports
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls maps fixMap exports
instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -369,6 +370,11 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+-- | Extract a map of fixity declarations only
+mkFixMap :: HsGroup Name -> FixMap
+mkFixMap group_ = M.fromList [ (n,f)
+ | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
+
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup Name -> [LHsDecl Name]
@@ -470,15 +476,16 @@ mkExportItems
-> [Name] -- exported names (orig)
-> [LHsDecl Name]
-> Maps
+ -> FixMap
-> Maybe [IE Name]
-> InstIfaceMap
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
modMap thisMod warnings gre exportedNames decls
- (maps@(docMap, argMap, subMap, declMap, instMap)) optExports instIfaceMap dflags =
+ maps@(docMap, argMap, subMap, declMap, instMap) fixMap optExports instIfaceMap dflags =
case optExports of
- Nothing -> fullModuleContents dflags warnings gre maps decls
+ Nothing -> fullModuleContents dflags warnings gre maps fixMap decls
Just exports -> liftM concat $ mapM lookupExport exports
where
lookupExport (IEVar x) = declWith x
@@ -486,7 +493,7 @@ mkExportItems
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap
lookupExport (IEGroup lev docStr) = liftErrMsg $
ifDoc (processDocString dflags gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
@@ -511,7 +518,7 @@ mkExportItems
case findDecl t of
([L _ (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
- export <- hiValExportItem dflags t doc
+ export <- hiValExportItem dflags t doc $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
@@ -568,12 +575,13 @@ mkExportItems
mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
- mkExportDecl n decl (doc, subs) = decl'
+ mkExportDecl name decl (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' []
- mdl = nameModule n
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities
+ mdl = nameModule name
subs' = filter (isExported . fst) subs
sub_names = map fst subs'
+ fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
isExported = (`elem` exportedNames)
@@ -600,12 +608,16 @@ hiDecl dflags t = do
Just x -> return (Just (tyThingToLHsDecl x))
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc = do
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc fixity = do
mayDecl <- hiDecl dflags name
case mayDecl of
Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl decl doc [] [])
+ Just decl -> return (ExportDecl decl doc [] [] fixities)
+ where
+ fixities = case fixity of
+ Just f -> [(name, f)]
+ Nothing -> []
-- | Lookup docs for a declaration from maps.
@@ -643,9 +655,10 @@ moduleExports :: Module -- ^ Module A
-> IfaceMap -- ^ Already created interfaces
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
+ -> FixMap
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps
- | m == thisMod = fullModuleContents dflags warnings gre maps decls
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap
+ | m == thisMod = fullModuleContents dflags warnings gre maps fixMap decls
| otherwise =
case M.lookup m ifaceMap of
Just iface
@@ -683,8 +696,9 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) decls =
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap
+ -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
-- A type signature can have multiple names, like:
@@ -711,18 +725,21 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem dflags name doc)
+ fmap Just (hiValExportItem dflags name doc $ M.lookup name fixMap)
| otherwise = return Nothing
mkExportItem decl@(L _ (InstD d))
| Just name <- M.lookup (getInstLoc d) instMap =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [])
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs))
mkExportItem decl
| name:_ <- getMainDeclBinder (unLoc decl) =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [])
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs))
| otherwise = return Nothing
+ fixities name subs = [ (n,f) | n <- name : map fst subs
+ , Just f <- [M.lookup n fixMap] ]
+
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 59b1185477..4bf39dfbd7 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -411,6 +411,9 @@ renameSig sig = case sig of
lreq' <- renameLContext lreq
lprov' <- renameLContext lprov
return $ PatSynSig lname' args' ltype' lreq' lprov'
+ FixSig (FixitySig lname fixity) -> do
+ lname' <- renameL lname
+ return $ FixSig (FixitySig lname' fixity)
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
@@ -474,7 +477,7 @@ renameExportItem item = case item of
ExportGroup lev id_ doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id_ doc')
- ExportDecl decl doc subs instances -> do
+ ExportDecl decl doc subs instances fixities -> do
decl' <- renameLDecl decl
doc' <- renameDocForDecl doc
subs' <- mapM renameSub subs
@@ -482,7 +485,10 @@ renameExportItem item = case item of
inst' <- renameInstHead inst
idoc' <- mapM renameDoc idoc
return (inst', idoc')
- return (ExportDecl decl' doc' subs' instances')
+ fixities' <- forM fixities $ \(name, fixity) -> do
+ name' <- lookupRn name
+ return (name', fixity)
+ return (ExportDecl decl' doc' subs' instances' fixities')
ExportNoDecl x subs -> do
x' <- lookupRn x
subs' <- mapM lookupRn subs
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index a3d731afb4..24f9e040f8 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -18,6 +18,7 @@
module Haddock.Types (
module Haddock.Types
, HsDocString, LHsDocString
+ , Fixity(..)
) where
import Data.Foldable
@@ -28,6 +29,7 @@ import Control.DeepSeq
import Data.Typeable
import Data.Map (Map)
import qualified Data.Map as Map
+import BasicTypes (Fixity(..))
import GHC hiding (NoLink)
import DynFlags (ExtensionFlag, Language)
import OccName
@@ -47,6 +49,7 @@ type ArgMap a = Map Name (Map Int (Doc a))
type SubMap = Map Name [Name]
type DeclMap = Map Name [LHsDecl Name]
type InstMap = Map SrcSpan Name
+type FixMap = Map Name Fixity
type SrcMap = Map PackageId FilePath
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
@@ -195,6 +198,9 @@ data ExportItem name
-- | Instances relevant to this declaration, possibly with
-- documentation.
, expItemInstances :: ![DocInstance name]
+
+ -- | Fixity decls relevant to this declaration (including subordinates).
+ , expItemFixities :: ![(name, Fixity)]
}
-- | An exported entity for which we have no documentation (perhaps because it
--
GitLab