Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
4ac9e902
Commit
4ac9e902
authored
Nov 04, 2014
by
eir@cis.upenn.edu
Browse files
Fix
#8100
, by adding StandaloneDerivD to TH's Dec type.
parent
767feb37
Changes
7
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMeta.hs
View file @
4ac9e902
...
...
@@ -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_s
tandalone
_d
eriv
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
repS
tandalone
D
eriv
D
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
...
...
compiler/hsSyn/Convert.lhs
View file @
4ac9e902
...
...
@@ -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)
...
...
libraries/template-haskell/Language/Haskell/TH.hs
View file @
4ac9e902
...
...
@@ -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
...
...
libraries/template-haskell/Language/Haskell/TH/Lib.hs
View file @
4ac9e902
...
...
@@ -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
...
...
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
View file @
4ac9e902
...
...
@@ -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
...
...
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
View file @
4ac9e902
...
...
@@ -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
...
...
testsuite/tests/th/all.T
View file @
4ac9e902
...
...
@@ -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
'])
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment