Fix #9064 by adding support for generic default signatures to TH.

8 files changed, 39 insertions, 17 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2c9e44b591..083c466baa 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -672,10 +672,9 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
                      return (concat sigs1) }
 
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
+rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig sigDName loc ty) nms
 rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
-rep_sig (L _   (GenericSig nm _))     = notHandled "Default type signatures" msg
-  where msg = text "Illegal default signature for" <+> quotes (ppr nm)
+rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms
 rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
 rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
@@ -683,12 +682,12 @@ rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
-rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
+rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)
-rep_ty_sig loc (L _ ty) nm
+rep_ty_sig mk_sig loc (L _ ty) nm
   = do { nm1 <- lookupLOcc nm
        ; ty1 <- rep_ty ty
-       ; sig <- repProto nm1 ty1
+       ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
   where
     -- We must special-case the top-level explicit for-all of a TypeSig
@@ -703,7 +702,6 @@ rep_ty_sig loc (L _ ty) nm
 
     rep_ty ty = repTy ty
 
-
 rep_inline :: Located Name
            -> InlinePragma      -- Never defaultInlinePragma
            -> SrcSpan
@@ -1820,8 +1818,8 @@ repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 
-repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
+repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
@@ -2120,7 +2118,7 @@ templateHaskellNames = [
     funDName, valDName, dataDName, newtypeDName, tySynDName,
     classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName,
     pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
-    pragRuleDName, pragAnnDName,
+    pragRuleDName, pragAnnDName, defaultSigDName,
     familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
     tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
     infixLDName, infixRDName, infixNDName,
@@ -2346,7 +2344,7 @@ parSName    = libFun (fsLit "parS")    parSIdKey
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
     pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
-    familyNoKindDName, standaloneDerivDName,
+    familyNoKindDName, standaloneDerivDName, defaultSigDName,
     familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
     closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
     infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
@@ -2360,6 +2358,7 @@ instanceDName     = libFun (fsLit "instanceD")     instanceDIdKey
 standaloneDerivDName
                   = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
 sigDName          = libFun (fsLit "sigD")          sigDIdKey
+defaultSigDName   = libFun (fsLit "defaultSigD")   defaultSigDIdKey
 forImpDName       = libFun (fsLit "forImpD")       forImpDIdKey
 pragInlDName      = libFun (fsLit "pragInlD")      pragInlDIdKey
 pragSpecDName     = libFun (fsLit "pragSpecD")     pragSpecDIdKey
@@ -2711,7 +2710,7 @@ parSIdKey        = mkPreludeMiscIdUnique 323
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
     pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
-    pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey,
+    pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey,
     dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey,
     closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique
@@ -2742,6 +2741,7 @@ infixRDIdKey                 = mkPreludeMiscIdUnique 353
 infixNDIdKey                 = mkPreludeMiscIdUnique 354
 roleAnnotDIdKey              = mkPreludeMiscIdUnique 355
 standaloneDerivDIdKey        = mkPreludeMiscIdUnique 356
+defaultSigDIdKey             = mkPreludeMiscIdUnique 357
 
 -- type Cxt = ...
 cxtIdKey :: Unique
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index d904a835f2..9ad594c698 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -312,6 +312,11 @@ cvtDec (TH.StandaloneDerivD cxt ty)
        ; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty'
        ; returnJustL $ DerivD $
          DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
+
+cvtDec (TH.DefaultSigD nm typ)
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType typ
+       ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' }
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
 cvtTySynEqn tc (TySynEqn lhs rhs)
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index ea467f0ad0..f2efb2ae58 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1308,15 +1308,22 @@ reifyClass cls
   = do  { cxt <- reifyCxt theta
         ; inst_envs <- tcGetInstEnvs
         ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
-        ; ops <- mapM reify_op op_stuff
+        ; ops <- concatMapM reify_op op_stuff
         ; tvs' <- reifyTyVars tvs
         ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
         ; return (TH.ClassI dec insts ) }
   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds
-    reify_op (op, _) = do { ty <- reifyType (idType op)
-                          ; return (TH.SigD (reifyName op) ty) }
+    reify_op (op, def_meth)
+      = do { ty <- reifyType (idType op)
+           ; let nm' = reifyName op
+           ; case def_meth of
+                GenDefMeth gdm_nm ->
+                  do { gdm_id <- tcLookupId gdm_nm
+                     ; gdm_ty <- reifyType (idType gdm_id)
+                     ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] }
+                _ -> return [TH.SigD nm' ty] }
 
 ------------------------------
 -- | Annotate (with TH.SigT) a type if the first parameter is True
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 1919079108..e038a3ba6b 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -124,7 +124,7 @@ module Language.Haskell.TH(
     -- **** Data
         valD, funD, tySynD, dataD, newtypeD,
     -- **** Class
-    classD, instanceD, sigD, standaloneDerivD,
+    classD, instanceD, sigD, standaloneDerivD, defaultSigD,
     -- **** Role annotations
     roleAnnotD,
     -- **** Type Family / Data Family
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 04f8fba610..efe597275b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -466,6 +466,12 @@ standaloneDerivD ctxtq tyq =
     ty   <- tyq
     return $ StandaloneDerivD ctxt ty
 
+defaultSigD :: Name -> TypeQ -> DecQ
+defaultSigD n tyq =
+  do
+    ty <- tyq
+    return $ DefaultSigD n ty
+
 tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
 tySynEqn lhs rhs =
   do
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index caa0183131..5f3a0c6c9b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -330,6 +330,9 @@ ppr_dec _ (RoleAnnotD name roles)
 ppr_dec _ (StandaloneDerivD cxt ty)
   = hsep [ text "deriving instance", pprCxt cxt, ppr ty ]
 
+ppr_dec _ (DefaultSigD n ty)
+  = hsep [ text "default", pprPrefixOcc n, text "::", ppr ty ]
+
 ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
 ppr_data maybeInst ctxt t argsDoc cs decs
   = sep [text "data" <+> maybeInst
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 17fdc85c60..ddbe3a98e2 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1216,6 +1216,7 @@ data Dec
 
   | RoleAnnotD Name [Role]        -- ^ @{ type role T nominal representational }@
   | StandaloneDerivD Cxt Type     -- ^ @{ deriving instance Ord a => Ord (Foo a) }@
+  | DefaultSigD Name Type         -- ^ @{ default size :: Data a => a -> Int }@
   deriving( Show, Eq, Data, Typeable, Generic )
 
 -- | One equation of a type family instance or closed type family. The
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 86e7fd87f8..90efcbd427 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -338,4 +338,4 @@ test('T9738', normal, compile, ['-v0'])
 test('T9081', normal, compile, ['-v0'])
 test('T9066', normal, compile, ['-v0'])
 test('T8100', normal, compile, ['-v0'])
-test('T9064', expect_broken(9064), compile, ['-v0'])
+test('T9064', normal, compile, ['-v0'])