Commit 1292c17e authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Allow TH quoting of assoc type defaults.

This fixes #10811.
parent 79b8e891
...@@ -251,7 +251,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn } ...@@ -251,7 +251,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs, tcdFDs = fds, tcdTyVars = tvs, tcdFDs = fds,
tcdSigs = sigs, tcdMeths = meth_binds, tcdSigs = sigs, tcdMeths = meth_binds,
tcdATs = ats, tcdATDefs = [] })) tcdATs = ats, tcdATDefs = atds }))
= do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
; dec <- addTyVarBinds tvs $ \bndrs -> ; dec <- addTyVarBinds tvs $ \bndrs ->
do { cxt1 <- repLContext cxt do { cxt1 <- repLContext cxt
...@@ -259,17 +259,13 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ...@@ -259,17 +259,13 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; binds1 <- rep_binds meth_binds ; binds1 <- rep_binds meth_binds
; fds1 <- repLFunDeps fds ; fds1 <- repLFunDeps fds
; ats1 <- repFamilyDecls ats ; ats1 <- repFamilyDecls ats
; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) ; atds1 <- repAssocTyFamDefaults atds
; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1)
; repClass cxt1 cls1 bndrs fds1 decls1 ; repClass cxt1 cls1 bndrs fds1 decls1
} }
; return $ Just (loc, dec) ; return $ Just (loc, dec)
} }
-- Un-handled cases
repTyClD (L loc d) = putSrcSpanDs loc $
do { warnDs (hang ds_msg 4 (ppr d))
; return Nothing }
------------------------- -------------------------
repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRoleD (L loc (RoleAnnotDecl tycon roles)) repRoleD (L loc (RoleAnnotDecl tycon roles))
...@@ -376,6 +372,22 @@ repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = ...@@ -376,6 +372,22 @@ repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ]
repAssocTyFamDefaults = mapM rep_deflt
where
-- very like repTyFamEqn, but different in the details
rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ)
rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
, tfe_pats = bndrs
, tfe_rhs = rhs }))
= addTyClTyVarBinds bndrs $ \ _ ->
do { tc1 <- lookupLOcc tc
; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs
; eqn1 <- repTySynEqn tys2 rhs1
; repTySynInst tc1 eqn1 }
------------------------- -------------------------
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
-> HsDataDefn Name -> DsM (LHsTyVarBndrs Name) -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
...@@ -597,9 +609,6 @@ repAnnProv (TypeAnnProvenance (L _ n)) ...@@ -597,9 +609,6 @@ repAnnProv (TypeAnnProvenance (L _ n))
repAnnProv ModuleAnnProvenance repAnnProv ModuleAnnProvenance
= rep2 moduleAnnotationName [] = rep2 moduleAnnotationName []
ds_msg :: SDoc
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
------------------------------------------------------- -------------------------------------------------------
-- Constructors -- Constructors
------------------------------------------------------- -------------------------------------------------------
......
...@@ -47,6 +47,7 @@ module HsTypes ( ...@@ -47,6 +47,7 @@ module HsTypes (
hsExplicitTvs, hsExplicitTvs,
hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
hsLTyVarBndrsToTypes,
splitLHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType, splitHsFunType,
...@@ -659,6 +660,20 @@ hsLTyVarLocName = fmap hsTyVarName ...@@ -659,6 +660,20 @@ hsLTyVarLocName = fmap hsTyVarName
hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell
-- quoting for type family equations.
hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name
hsLTyVarBndrToType = fmap cvt
where cvt (UserTyVar n) = HsTyVar n
cvt (KindedTyVar (L name_loc n) kind) = HsKindSig (L name_loc (HsTyVar n))
kind
-- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell
-- quoting for type family equations. Works on *type* variable only, no kind
-- vars.
hsLTyVarBndrsToTypes :: LHsTyVarBndrs name -> [LHsType name]
hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs
--------------------- ---------------------
mkAnonWildCardTy :: HsType RdrName mkAnonWildCardTy :: HsType RdrName
mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
......
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module Bug where
$([d| class C a where
type F a
type F a = a |])
...@@ -353,3 +353,4 @@ test('T10704', ...@@ -353,3 +353,4 @@ test('T10704',
['T10704', '-v0']) ['T10704', '-v0'])
test('T6018th', normal, compile_fail, ['-v0']) test('T6018th', normal, compile_fail, ['-v0'])
test('TH_namePackage', normal, compile_and_run, ['-v0']) test('TH_namePackage', normal, compile_and_run, ['-v0'])
test('T10811', normal, compile, ['-v0'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment