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
e4efb7b8
Commit
e4efb7b8
authored
Nov 04, 2014
by
eir@cis.upenn.edu
Browse files
Fix
#9064
by adding support for generic default signatures to TH.
parent
fe71a7e6
Changes
8
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMeta.hs
View file @
e4efb7b8
...
...
@@ -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
sig
DName
[
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
...
...
compiler/hsSyn/Convert.lhs
View file @
e4efb7b8
...
...
@@ -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)
...
...
compiler/typecheck/TcSplice.lhs
View file @
e4efb7b8
...
...
@@ -1308,15 +1308,22 @@ reifyClass cls
= do { cxt <- reifyCxt theta
; inst_envs <- tcGetInstEnvs
; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
; ops <-
m
apM reify_op op_stuff
; ops <-
concatM
apM 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
...
...
libraries/template-haskell/Language/Haskell/TH.hs
View file @
e4efb7b8
...
...
@@ -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
...
...
libraries/template-haskell/Language/Haskell/TH/Lib.hs
View file @
e4efb7b8
...
...
@@ -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
...
...
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
View file @
e4efb7b8
...
...
@@ -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
...
...
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
View file @
e4efb7b8
...
...
@@ -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
...
...
testsuite/tests/th/all.T
View file @
e4efb7b8
...
...
@@ -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
'])
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