Tue Nov 28 11:34:12 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.16,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11258,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T14529,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13,wip/ttg6-unrevert-2017-11-22
Link       : http://git.haskell.org/haddock.git/commitdiff/060b986c641cd496395b2d13dc316fc84462a7a4

>---------------------------------------------------------------

commit 060b986c641cd496395b2d13dc316fc84462a7a4
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Wed Jul 15 20:25:41 2015 +0200

    Implement tuple syntax sugaring logic for specialized types.


>---------------------------------------------------------------

060b986c641cd496395b2d13dc316fc84462a7a4
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 36 ++++++++++++++++++++--
 1 file changed, 34 insertions(+), 2 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 30501a1..a2cb879 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -15,6 +15,7 @@ import Haddock.Syb
 import GHC
 import Name
 
+import Control.Monad
 import Data.Data
 
 
@@ -64,5 +65,36 @@ sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp)
 sugarListsStep typ = typ
 
 
-sugarTuples :: HsType name -> HsType name
-sugarTuples = id
+sugarTuples :: forall name. (NamedThing name, DataId name)
+            => HsType name -> HsType name
+sugarTuples = everywhere $
+    mkT (sugarTuplesStep :: HsType name -> HsType name)
+
+
+sugarTuplesStep :: NamedThing name => HsType name -> HsType name
+sugarTuplesStep typ =
+    aux [] typ
+  where
+    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+    aux apps (HsParTy (L _ typ')) = aux apps typ'
+    aux apps (HsTyVar name)
+        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+      where
+        name' = getName name
+        strName = occNameString . nameOccName $ name'
+        suitable = case parseTupleArity strName of
+            Just arity -> arity == length apps
+            Nothing -> False
+    aux _ _ = typ
+
+
+parseTupleArity :: String -> Maybe Int
+parseTupleArity ('(':commas) = do
+    n <- parseCommas commas
+    guard $ n /= 0
+    return $ n + 1
+  where
+    parseCommas (',':rest) = (+ 1) <$> parseCommas rest
+    parseCommas ")" = Just 0
+    parseCommas _ = Nothing
+parseTupleArity _ = Nothing

