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 /compiler/deSugar/DsMeta.hs | |
| parent | 79b8e891d88bd4018e31be042364e314a25fbb41 (diff) | |
| download | haskell-1292c17e61400dfa0c27eddff4bea6a935006657.tar.gz | |
Allow TH quoting of assoc type defaults.
This fixes #10811.
Diffstat (limited to 'compiler/deSugar/DsMeta.hs')
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 29 |
1 files changed, 19 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 ------------------------------------------------------- |