Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
1292c17e
Commit
1292c17e
authored
Sep 19, 2015
by
eir@cis.upenn.edu
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Allow TH quoting of assoc type defaults.
This fixes
#10811
.
parent
79b8e891
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
42 additions
and
10 deletions
+42
-10
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMeta.hs
+19
-10
compiler/hsSyn/HsTypes.hs
compiler/hsSyn/HsTypes.hs
+15
-0
testsuite/tests/th/T10811.hs
testsuite/tests/th/T10811.hs
+7
-0
testsuite/tests/th/all.T
testsuite/tests/th/all.T
+1
-0
No files found.
compiler/deSugar/DsMeta.hs
View file @
1292c17e
...
...
@@ -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
-------------------------------------------------------
...
...
compiler/hsSyn/HsTypes.hs
View file @
1292c17e
...
...
@@ -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
)
...
...
testsuite/tests/th/T10811.hs
0 → 100644
View file @
1292c17e
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module
Bug
where
$
(
[
d
|
class C a where
type F a
type F a = a
|]
)
testsuite/tests/th/all.T
View file @
1292c17e
...
...
@@ -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
'])
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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