diff options
author | Richard Eisenberg <eir@cis.upenn.edu> | 2015-09-19 15:43:15 -0400 |
---|---|---|
committer | Richard Eisenberg <eir@cis.upenn.edu> | 2015-09-20 21:39:15 -0400 |
commit | 1292c17e61400dfa0c27eddff4bea6a935006657 (patch) | |
tree | 2fd14d31648371f8ec3cfed660ed7634ee306e2b | |
parent | 79b8e891d88bd4018e31be042364e314a25fbb41 (diff) | |
download | haskell-1292c17e61400dfa0c27eddff4bea6a935006657.tar.gz |
Allow TH quoting of assoc type defaults.
This fixes #10811.
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 29 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/th/T10811.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 42 insertions, 10 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index a762810419..39eab05a80 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -251,7 +251,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, tcdSigs = sigs, tcdMeths = meth_binds, - tcdATs = ats, tcdATDefs = [] })) + tcdATs = ats, tcdATDefs = atds })) = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] ; dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt @@ -259,17 +259,13 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; binds1 <- rep_binds meth_binds ; fds1 <- repLFunDeps fds ; 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 } ; 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 (L loc (RoleAnnotDecl tycon roles)) @@ -376,6 +372,22 @@ repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] 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 -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name) @@ -597,9 +609,6 @@ repAnnProv (TypeAnnProvenance (L _ n)) repAnnProv ModuleAnnProvenance = rep2 moduleAnnotationName [] -ds_msg :: SDoc -ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") - ------------------------------------------------------- -- Constructors ------------------------------------------------------- diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 0393ccac2d..8353bb63f2 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -47,6 +47,7 @@ module HsTypes ( hsExplicitTvs, hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + hsLTyVarBndrsToTypes, splitLHsInstDeclTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, @@ -659,6 +660,20 @@ hsLTyVarLocName = fmap hsTyVarName hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] 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 = HsWildCardTy (AnonWildCard PlaceHolder) diff --git a/testsuite/tests/th/T10811.hs b/testsuite/tests/th/T10811.hs new file mode 100644 index 0000000000..3fac1905d6 --- /dev/null +++ b/testsuite/tests/th/T10811.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module Bug where + +$([d| class C a where + type F a + type F a = a |]) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index eea0fa98c2..85dae8b05a 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -353,3 +353,4 @@ test('T10704', ['T10704', '-v0']) test('T6018th', normal, compile_fail, ['-v0']) test('TH_namePackage', normal, compile_and_run, ['-v0']) +test('T10811', normal, compile, ['-v0']) |