From cdc81a1b73bd4d1b330a32870d4369e1a2af3610 Mon Sep 17 00:00:00 2001
From: Ömer Sinan Ağacan <omeragacan@gmail.com>
Date: Fri, 1 Jul 2016 10:11:48 +0000
Subject: Add support for unboxed sums

---
 haddock-api/src/Haddock/Backends/LaTeX.hs       | 5 +++++
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs  | 4 ++++
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 6 +++++-
 haddock-api/src/Haddock/Interface/Rename.hs     | 1 +
 haddock-api/src/Haddock/Interface/Specialize.hs | 1 +
 5 files changed, 16 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 3b0c38c4..ffb4d782 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -885,6 +885,10 @@ tupleParens HsUnboxedTuple = ubxParenList
 tupleParens _              = parenList
 
 
+sumParens :: [LaTeX] -> LaTeX
+sumParens = ubxparens . hsep . punctuate (text " | ")
+
+
 -------------------------------------------------------------------------------
 -- * Rendering of HsType
 --
@@ -948,6 +952,7 @@ ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty
 ppr_mono_ty _         (HsTyVar (L _ name)) _ = ppDocName name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u
 ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _         (HsSumTy tys) u       = sumParens (map (ppLType u) tys)
 ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
 ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)
 ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ed9fd964..c6f1100b 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -913,6 +913,9 @@ tupleParens HsUnboxedTuple = ubxParenList
 tupleParens _              = parenList
 
 
+sumParens :: [Html] -> Html
+sumParens = ubxSumList
+
 --------------------------------------------------------------------------------
 -- * Rendering of HsType
 --------------------------------------------------------------------------------
@@ -989,6 +992,7 @@ ppr_mono_ty _         (HsBangTy b ty)     u q = ppBang b +++ ppLParendType u q t
 ppr_mono_ty _         (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name
 ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
 ppr_mono_ty _         (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
+ppr_mono_ty _         (HsSumTy tys) u q = sumParens (map (ppLType u q) tys)
 ppr_mono_ty _         (HsKindSig ty kind) u q =
     parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
 ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 391bb50c..a8b4a4ec 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -20,7 +20,7 @@ module Haddock.Backends.Xhtml.Utils (
   (<+>), (<=>), char,
   keyword, punctuate,
 
-  braces, brackets, pabrackets, parens, parenList, ubxParenList,
+  braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
   arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
 
   hsep, vcat,
@@ -177,6 +177,10 @@ ubxParenList :: [Html] -> Html
 ubxParenList = ubxparens . hsep . punctuate comma
 
 
+ubxSumList :: [Html]  -> Html
+ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
+
+
 ubxparens :: Html -> Html
 ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
 
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index d786d0cc..cf3b72ac 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -238,6 +238,7 @@ renameType t = case t of
   HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
 
   HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+  HsSumTy ts -> HsSumTy <$> mapM renameLType ts
 
   HsOpTy a (L loc op) b -> do
     op' <- rename op
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 198bc4ff..3e0df4e1 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -273,6 +273,7 @@ renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
 renameType (HsListTy lt) = HsListTy <$> renameLType lt
 renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
 renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
 renameType (HsOpTy la lop lb) =
     HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
 renameType (HsParTy lt) = HsParTy <$> renameLType lt
-- 
cgit v1.2.3