diff options
| -rw-r--r-- | html-test/ref/Bug8.html | 6 | ||||
| -rw-r--r-- | html-test/ref/Operators.html | 379 | ||||
| -rw-r--r-- | html-test/src/Operators.hs | 56 | ||||
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Backends/LaTeX.hs | 11 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 10 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 175 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Utils.hs | 17 | ||||
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 53 | ||||
| -rw-r--r-- | src/Haddock/Interface/Rename.hs | 10 | ||||
| -rw-r--r-- | src/Haddock/Types.hs | 6 | 
11 files changed, 621 insertions, 104 deletions
| diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html index f3845cb2..7e5b5fee 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 00000000..89ebbbbf --- /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 00000000..a2e30c18 --- /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 1f098d6d..dbce787f 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 24e8b7c8..e6108ab6 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 bdd1afdc..4eda68f6 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 9e72d4ad..20db5df1 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 232e18cc..cbcbbd6d 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 f3658a12..37d0fe7d 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 59b11854..4bf39dfb 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 a3d731af..24f9e040 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 | 
