[commit: ghc] wip/rae: Allow TH quoting of assoc type defaults. (e5e6e47)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/e5e6e47d177a78446ce1bdcaf923dfb6732cd5b3/ghc

>---------------------------------------------------------------

commit e5e6e47d177a78446ce1bdcaf923dfb6732cd5b3
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Sat Sep 19 15:43:15 2015 -0400

    Allow TH quoting of assoc type defaults.
    
    This fixes #10811.


>---------------------------------------------------------------

e5e6e47d177a78446ce1bdcaf923dfb6732cd5b3
 compiler/deSugar/DsMeta.hs   | 29 +++++++++++++++++++----------
 compiler/hsSyn/HsTypes.hs    | 15 +++++++++++++++
 testsuite/tests/th/T10811.hs |  7 +++++++
 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 a762810..39eab05 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 0393cca..8353bb6 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 0000000..3fac190
--- /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 eea0fa9..85dae8b 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'])