aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Convert.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
-rw-r--r--haddock-api/src/Haddock/Convert.hs18
1 files changed, 16 insertions, 2 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 622837fa..aff5c57b 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 )
@@ -463,8 +463,18 @@ synifyType _ (TyConApp tc tys)
, dataConSourceArity dc == length vis_tys
= noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys)
-- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
+ | getName tc == listTyConName, [ty] <- vis_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