diff options
| author | Alec Theriault <alec.theriault@gmail.com> | 2018-08-27 14:15:25 -0700 |
|---|---|---|
| committer | Alec Theriault <alec.theriault@gmail.com> | 2018-08-27 14:15:25 -0700 |
| commit | 2122de5473fd5b434af690ff9ccb1a2e58491f8c (patch) | |
| tree | 2f0d17db91671d2981582252113f3343880ab733 | |
| parent | 6a9ada2426579b72696514b3fd081aacac9c5740 (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]))))
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 16 |
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 |