From 2122de5473fd5b434af690ff9ccb1a2e58491f8c Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Mon, 27 Aug 2018 14:15:25 -0700
Subject: Properly synify promoted list types

We reconstruct promoted list literals whenever possible. That means
that 'synifyType' produces

   '[Int, Bool, ()]

instead of

   (Int ': (() ': (Bool ': ([] :: [Type]))))
---
 haddock-api/src/Haddock/Convert.hs | 16 +++++++++++++++-
 1 file changed, 15 insertions(+), 1 deletion(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 622837fa..96d3798b 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -37,7 +37,7 @@ import Type
 import TyCoRep
 import TysPrim ( alphaTyVars )
 import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
-                  , unitTy )
+                  , unitTy, promotedNilDataCon, promotedConsDataCon )
 import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
                  , liftedRepDataConKey )
 import Unique ( getUnique )
@@ -465,6 +465,16 @@ synifyType _ (TyConApp tc tys)
       -- ditto for lists
       | getName tc == listTyConName, [ty] <- tys =
          noLoc $ HsListTy noExt (synifyType WithinType ty)
+      | tc == promotedNilDataCon, [] <- vis_tys
+      = noLoc $ HsExplicitListTy noExt Promoted []
+      | tc == promotedConsDataCon
+      , [ty1, ty2] <- vis_tys
+      = let hTy = synifyType WithinType ty1
+        in case synifyType WithinType ty2 of
+             tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy
+                 -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy')
+                 | otherwise
+                 -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy
       -- ditto for implicit parameter tycons
       | tc `hasKey` ipClassKey
       , [name, ty] <- tys
@@ -572,6 +582,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
 synifyKindSig :: Kind -> LHsKind GhcRn
 synifyKindSig k = synifyType WithinType k
 
+stripKindSig :: LHsType GhcRn -> LHsType GhcRn
+stripKindSig (L _ (HsKindSig _ t _)) = t
+stripKindSig t = t
+
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
 synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
     { ihdClsName = getName cls
-- 
cgit v1.2.3