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

Fix #8100, by adding StandaloneDerivD to TH's Dec type.

parent 767feb37
......@@ -137,26 +137,26 @@ repTopDs group@(HsGroup { hs_valds = valds
-- only "T", not "Foo:T" where Foo is the current module
decls <- addBinds ss (
do { val_ds <- rep_val_binds valds
; _ <- mapM no_splice splcds
; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds)
; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
; inst_ds <- mapM repInstD instds
; _ <- mapM no_standalone_deriv derivds
; fix_ds <- mapM repFixD fixds
; _ <- mapM no_default_decl defds
; for_ds <- mapM repForD fords
; _ <- mapM no_warn warnds
; ann_ds <- mapM repAnnD annds
; rule_ds <- mapM repRuleD ruleds
; _ <- mapM no_vect vects
; _ <- mapM no_doc docs
do { val_ds <- rep_val_binds valds
; _ <- mapM no_splice splcds
; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds)
; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
; inst_ds <- mapM repInstD instds
; deriv_ds <- mapM repStandaloneDerivD derivds
; fix_ds <- mapM repFixD fixds
; _ <- mapM no_default_decl defds
; for_ds <- mapM repForD fords
; _ <- mapM no_warn warnds
; ann_ds <- mapM repAnnD annds
; rule_ds <- mapM repRuleD ruleds
; _ <- mapM no_vect vects
; _ <- mapM no_doc docs
-- more needed
; return (de_loc $ sort_by_loc $
val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
++ inst_ds ++ rule_ds ++ for_ds
++ ann_ds) }) ;
++ ann_ds ++ deriv_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
......@@ -169,8 +169,6 @@ repTopDs group@(HsGroup { hs_valds = valds
where
no_splice (L loc _)
= notHandledL loc "Splices within declaration brackets" empty
no_standalone_deriv (L loc (DerivDecl { deriv_type = deriv_ty }))
= notHandledL loc "Standalone-deriving" (ppr deriv_ty)
no_default_decl (L loc decl)
= notHandledL loc "Default declarations" (ppr decl)
no_warn (L loc (Warning thing _))
......@@ -422,6 +420,18 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
= do { dec <- addTyVarBinds tvs $ \_ ->
do { cxt' <- repContext cxt
; cls_tcon <- repTy (HsTyVar (unLoc cls))
; cls_tys <- repLTys tys
; inst_ty <- repTapps cls_tcon cls_tys
; repDeriv cxt' inst_ty }
; return (loc, dec) }
where
Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
= do { let tc_name = tyFamInstDeclLName decl
......@@ -1741,6 +1751,9 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds]
repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty]
repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
-> Core TH.Phases -> DsM (Core TH.DecQ)
repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
......@@ -2105,7 +2118,7 @@ templateHaskellNames = [
bindSName, letSName, noBindSName, parSName,
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceDName, sigDName, forImpDName,
classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragAnnDName,
familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
......@@ -2333,7 +2346,7 @@ parSName = libFun (fsLit "parS") parSIdKey
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
familyNoKindDName,
familyNoKindDName, standaloneDerivDName,
familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
......@@ -2344,6 +2357,8 @@ newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey
instanceDName = libFun (fsLit "instanceD") instanceDIdKey
standaloneDerivDName
= libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
forImpDName = libFun (fsLit "forImpD") forImpDIdKey
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
......@@ -2697,7 +2712,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey,
closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 330
......@@ -2726,6 +2741,7 @@ infixLDIdKey = mkPreludeMiscIdUnique 352
infixRDIdKey = mkPreludeMiscIdUnique 353
infixNDIdKey = mkPreludeMiscIdUnique 354
roleAnnotDIdKey = mkPreludeMiscIdUnique 355
standaloneDerivDIdKey = mkPreludeMiscIdUnique 356
-- type Cxt = ...
cxtIdKey :: Unique
......
......@@ -305,6 +305,13 @@ cvtDec (TH.RoleAnnotD tc roles)
= do { tc' <- tconNameL tc
; let roles' = map (noLoc . cvtRole) roles
; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
cvtDec (TH.StandaloneDerivD cxt ty)
= do { cxt' <- cvtContext cxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty'
; returnJustL $ DerivD $
DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
......
......@@ -124,7 +124,7 @@ module Language.Haskell.TH(
-- **** Data
valD, funD, tySynD, dataD, newtypeD,
-- **** Class
classD, instanceD, sigD,
classD, instanceD, sigD, standaloneDerivD,
-- **** Role annotations
roleAnnotD,
-- **** Type Family / Data Family
......
......@@ -459,6 +459,13 @@ closedTypeFamilyKindD tc tvs kind eqns =
roleAnnotD :: Name -> [Role] -> DecQ
roleAnnotD name roles = return $ RoleAnnotD name roles
standaloneDerivD :: CxtQ -> TypeQ -> DecQ
standaloneDerivD ctxtq tyq =
do
ctxt <- ctxtq
ty <- tyq
return $ StandaloneDerivD ctxt ty
tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
tySynEqn lhs rhs =
do
......
......@@ -327,6 +327,9 @@ ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns)
ppr_dec _ (RoleAnnotD name roles)
= hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
ppr_dec _ (StandaloneDerivD cxt ty)
= hsep [ text "deriving instance", pprCxt cxt, ppr ty ]
ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
ppr_data maybeInst ctxt t argsDoc cs decs
= sep [text "data" <+> maybeInst
......
......@@ -1215,6 +1215,7 @@ data Dec
[TySynEqn] -- ^ @{ type family F a b :: * where ... }@
| RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
| StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@
deriving( Show, Eq, Data, Typeable, Generic )
-- | One equation of a type family instance or closed type family. The
......
......@@ -337,4 +337,4 @@ test('T9084', normal, compile_fail, ['-v0'])
test('T9738', normal, compile, ['-v0'])
test('T9081', normal, compile, ['-v0'])
test('T9066', normal, compile, ['-v0'])
test('T8100', expect_broken(8100), compile, ['-v0'])
test('T8100', 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