aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-08-27 14:15:25 -0700
committerAlec Theriault <alec.theriault@gmail.com>2018-08-27 14:15:25 -0700
commit2122de5473fd5b434af690ff9ccb1a2e58491f8c (patch)
tree2f0d17db91671d2981582252113f3343880ab733 /haddock-api/src/Haddock
parent6a9ada2426579b72696514b3fd081aacac9c5740 (diff)
Properly synify promoted list types
We reconstruct promoted list literals whenever possible. That means that 'synifyType' produces '[Int, Bool, ()] instead of (Int ': (() ': (Bool ': ([] :: [Type]))))
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Convert.hs16
1 files changed, 15 insertions, 1 deletions
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