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

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

parent fe71a7e6
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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'])
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