aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-15 20:25:41 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commit060b986c641cd496395b2d13dc316fc84462a7a4 (patch)
treefe8e8c38ffa47b82b3cce21c3d2af669d7fb57b7 /haddock-api/src/Haddock/Backends/Xhtml
parent3f31e24656d42bc6c50f441e055b7ecc4fdec8d0 (diff)
Implement tuple syntax sugaring logic for specialized types.
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs36
1 files 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 30501a13..a2cb8799 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