diff options
Diffstat (limited to 'haddock-api/src/Haddock/Convert.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 43 |
1 files changed, 32 insertions, 11 deletions
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 96a1c01c..71a81190 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -26,6 +26,7 @@ import DataCon import FamInstEnv import HsSyn import Name +import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc ) @@ -34,9 +35,9 @@ import TyCon import Type import TyCoRep import TysPrim ( alphaTyVars, unliftedTypeKindTyConName ) -import TysWiredIn ( listTyConName, starKindTyConName ) +import TysWiredIn ( listTyConName, starKindTyConName, unitTy ) import PrelNames ( hasKey, eqTyConKey, ipClassKey - , tYPETyConKey, liftedDataConKey, unliftedDataConKey ) + , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ) import Unique ( getUnique ) import Util ( filterByList, filterOut ) import Var @@ -100,8 +101,7 @@ tyThingToLHsDecl t = case t of (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType - (patSynType ps)) + allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -144,7 +144,7 @@ synifyTyCon _coax tc in HsQTvs { hsq_implicit = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * - } + , hsq_dependent = emptyNameSet } , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: @@ -154,6 +154,7 @@ synifyTyCon _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing } + , tcdDataCusk = False , tcdFVs = placeHolderNamesTc } synifyTyCon _coax tc @@ -180,12 +181,11 @@ synifyTyCon _coax tc , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc) , fdResultSig = - synifyFamilyResultSig resultVar tyConResKind + synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) (familyTyConInjectivityInfo tc) } - tyConResKind = piResultTys (tyConKind tc) (mkTyVarTys (tyConTyVars tc)) synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc @@ -234,7 +234,7 @@ synifyTyCon coax tc in case lefts consRaw of [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn - , tcdFVs = placeHolderNamesTc } + , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity @@ -323,7 +323,8 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars Name synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs } + , hsq_explicit = map synifyTyVar ktvs + , hsq_dependent = emptyNameSet } synifyTyVar :: TyVar -> LHsTyVarBndr Name synifyTyVar tv @@ -358,17 +359,21 @@ synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) +synifyPatSynSigType :: PatSyn -> LHsSigType Name +-- Ditto (see synifySigType) +synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) + synifyType :: SynifyTypeState -> Type -> LHsType Name synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys - , lev `hasKey` liftedDataConKey + , lev `hasKey` ptrRepLiftedDataConKey = noLoc (HsTyVar (noLoc starKindTyConName)) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys - , lev `hasKey` unliftedDataConKey + , lev `hasKey` ptrRepUnliftedDataConKey = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc @@ -419,6 +424,22 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" +synifyPatSynType :: PatSyn -> LHsType Name +synifyPatSynType ps = let + (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] + -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", + -- i.e., an explicit empty context, which is what we need. This is not + -- possible by taking theta = [], as that will print no context at all + | otherwise = req_theta + sForAll [] s = s + sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_body = noLoc s } + sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta + , hst_body = noLoc s } + sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty + in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau + synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy mempty n synifyTyLit (StrTyLit s) = HsStrTy mempty s |