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
ef2491a3
Commit
ef2491a3
authored
Mar 14, 2012
by
Simon Peyton Jones
Browse files
Add fixity declarations to Template Haskell (Trac
#1541
)
There is an accompanying patch to the template-haskell library
parent
431c05b3
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMeta.hs
View file @
ef2491a3
...
...
@@ -124,16 +124,16 @@ repTopDs group
-- return (Data t [] ...more t's... }
-- The other important reason is that the output must mention
-- only "T", not "Foo:T" where Foo is the current module
decls
<-
addBinds
ss
(
do
{
fix_ds
<-
mapM
repFixD
(
hs_fixds
group
)
;
val_ds
<-
rep_val_binds
(
hs_valds
group
)
;
tycl_ds
<-
mapM
repTyClD
(
concat
(
hs_tyclds
group
))
;
inst_ds
<-
mapM
repInstD
(
hs_instds
group
)
;
for_ds
<-
mapM
repForD
(
hs_fords
group
)
;
-- more needed
return
(
de_loc
$
sort_by_loc
$
val_ds
++
catMaybes
tycl_ds
val_ds
++
catMaybes
tycl_ds
++
fix_ds
++
catMaybes
inst_ds
++
for_ds
)
})
;
decl_ty
<-
lookupType
decQTyConName
;
...
...
@@ -175,11 +175,12 @@ repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
repTyClD
tydecl
@
(
L
_
(
TyFamily
{}))
=
repTyFamily
tydecl
addTyVarBinds
repTyClD
(
L
loc
(
TyData
{
tcdND
=
DataType
,
tcdCtxt
=
cxt
,
repTyClD
(
L
loc
(
TyData
{
tcdND
=
DataType
,
tcdCtxt
=
cxt
,
tcdKindSig
=
mb_kind
,
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdTyPats
=
opt_tys
,
tcdCons
=
cons
,
tcdDerivs
=
mb_derivs
}))
=
do
{
tc1
<-
lookupLOcc
tc
-- See note [Binders and occurrences]
;
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
;
more_tvs
<-
mk_extra_tvs
mb_kind
;
dec
<-
addTyVarBinds
(
tvs
++
more_tvs
)
$
\
bndrs
->
do
{
cxt1
<-
repLContext
cxt
;
opt_tys1
<-
maybeMapM
repLTys
opt_tys
-- only for family insts
;
opt_tys2
<-
maybeMapM
(
coreList
typeQTyConName
)
opt_tys1
...
...
@@ -244,6 +245,34 @@ repTyClD (L loc d) = putSrcSpanDs loc $
do
{
warnDs
(
hang
ds_msg
4
(
ppr
d
))
;
return
Nothing
}
-------------------------
mk_extra_tvs
::
Maybe
(
HsBndrSig
(
LHsKind
Name
))
->
DsM
[
LHsTyVarBndr
Name
]
-- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
mk_extra_tvs
Nothing
=
return
[]
mk_extra_tvs
(
Just
(
HsBSig
hs_kind
_
))
=
go
hs_kind
where
go
::
LHsKind
Name
->
DsM
[
LHsTyVarBndr
Name
]
go
(
L
loc
(
HsFunTy
kind
rest
))
=
do
{
uniq
<-
newUnique
;
let
{
occ
=
mkTyVarOccFS
(
fsLit
"t"
)
;
nm
=
mkInternalName
uniq
occ
loc
;
hs_tv
=
L
loc
(
KindedTyVar
nm
(
HsBSig
kind
placeHolderBndrs
))
}
;
hs_tvs
<-
go
rest
;
return
(
hs_tv
:
hs_tvs
)
}
go
(
L
_
(
HsTyVar
n
))
|
n
==
liftedTypeKindTyConName
=
return
[]
go
_
=
failWithDs
(
hang
(
ptext
(
sLit
"Malformed kind signature"
))
2
(
ppr
hs_kind
))
-------------------------
-- The type variables in the head of families are treated differently when the
-- family declaration is associated. In that case, they are usage, not binding
-- occurences.
...
...
@@ -261,9 +290,9 @@ repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
;
bndrs1
<-
coreList
tyVarBndrTyConName
bndrs
;
case
opt_kind
of
Nothing
->
repFamilyNoKind
flav
tc1
bndrs1
Just
ki
->
do
{
ki1
<-
repKind
ki
;
repFamilyKind
flav
tc1
bndrs1
ki
1
}
Just
(
HsBSig
ki
_
)
->
do
{
ki1
<-
repKind
ki
;
repFamilyKind
flav
tc1
bndrs1
ki1
}
}
;
return
$
Just
(
loc
,
dec
)
}
...
...
@@ -314,7 +343,7 @@ repInstD (L loc (FamInstDecl fi_decl))
=
repTyClD
(
L
loc
fi_decl
)
repInstD
(
L
loc
(
ClsInstDecl
ty
binds
_
ats
))
-- Ignore user pragmas for now
repInstD
(
L
loc
(
ClsInstDecl
ty
binds
prags
ats
))
=
do
{
dec
<-
addTyVarBinds
tvs
$
\
_
->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
...
...
@@ -330,8 +359,9 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now
;
cls_tys
<-
repLTys
tys
;
inst_ty1
<-
repTapps
cls_tcon
cls_tys
;
binds1
<-
rep_binds
binds
;
prags1
<-
rep_sigs
prags
;
ats1
<-
repLAssocFamInst
ats
;
decls
<-
coreList
decQTyConName
(
ats1
++
binds1
)
;
decls
<-
coreList
decQTyConName
(
ats1
++
binds1
++
prags1
)
;
repInst
cxt1
inst_ty1
decls
}
;
return
(
Just
(
loc
,
dec
))
}
where
...
...
@@ -371,6 +401,17 @@ repSafety PlayRisky = rep2 unsafeName []
repSafety
PlayInterruptible
=
rep2
interruptibleName
[]
repSafety
PlaySafe
=
rep2
safeName
[]
repFixD
::
LFixitySig
Name
->
DsM
(
SrcSpan
,
Core
TH
.
DecQ
)
repFixD
(
L
loc
(
FixitySig
name
(
Fixity
prec
dir
)))
=
do
{
MkC
name'
<-
lookupLOcc
name
;
MkC
prec'
<-
coreIntLit
prec
;
let
rep_fn
=
case
dir
of
InfixL
->
infixLDName
InfixR
->
infixRDName
InfixN
->
infixNDName
;
dec
<-
rep2
rep_fn
[
prec'
,
name'
]
;
return
(
loc
,
dec
)
}
ds_msg
::
SDoc
ds_msg
=
ptext
(
sLit
"Cannot desugar this Template Haskell declaration:"
)
...
...
@@ -426,7 +467,7 @@ mkGadtCtxt data_tvs (ResTyGADT res_ty)
=
return
(
go
[]
[]
(
data_tvs
`
zip
`
tys
))
|
otherwise
=
failWithDs
(
ptext
(
sLit
"Malformed constructor result type"
)
<+>
ppr
res_ty
)
=
failWithDs
(
ptext
(
sLit
"Malformed constructor result type
:
"
)
<+>
ppr
res_ty
)
where
go
cxt
subst
[]
=
(
cxt
,
subst
)
go
cxt
subst
((
data_tv
,
ty
)
:
rest
)
...
...
@@ -607,7 +648,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
->
Core
TH
.
Name
->
DsM
(
Core
TH
.
TyVarBndr
)
repTyVarBndrWithKind
(
L
_
(
UserTyVar
{}))
nm
=
repPlainTV
nm
repTyVarBndrWithKind
(
L
_
(
KindedTyVar
_
(
HsBSig
ki
_
)
_
))
nm
repTyVarBndrWithKind
(
L
_
(
KindedTyVar
_
(
HsBSig
ki
_
)))
nm
=
repKind
ki
>>=
repKindedTV
nm
-- represent a type context
...
...
@@ -1963,7 +2004,8 @@ parSName = libFun (fsLit "parS") parSIdKey
funDName
,
valDName
,
dataDName
,
newtypeDName
,
tySynDName
,
classDName
,
instanceDName
,
sigDName
,
forImpDName
,
pragInlDName
,
pragSpecDName
,
pragSpecInlDName
,
familyNoKindDName
,
familyKindDName
,
dataInstDName
,
newtypeInstDName
,
tySynInstDName
::
Name
newtypeInstDName
,
tySynInstDName
,
infixLDName
,
infixRDName
,
infixNDName
::
Name
funDName
=
libFun
(
fsLit
"funD"
)
funDIdKey
valDName
=
libFun
(
fsLit
"valD"
)
valDIdKey
dataDName
=
libFun
(
fsLit
"dataD"
)
dataDIdKey
...
...
@@ -1981,6 +2023,9 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
dataInstDName
=
libFun
(
fsLit
"dataInstD"
)
dataInstDIdKey
newtypeInstDName
=
libFun
(
fsLit
"newtypeInstD"
)
newtypeInstDIdKey
tySynInstDName
=
libFun
(
fsLit
"tySynInstD"
)
tySynInstDIdKey
infixLDName
=
libFun
(
fsLit
"infixLD"
)
infixLDIdKey
infixRDName
=
libFun
(
fsLit
"infixRD"
)
infixRDIdKey
infixNDName
=
libFun
(
fsLit
"infixND"
)
infixNDIdKey
-- type Ctxt = ...
cxtName
::
Name
...
...
@@ -2245,7 +2290,8 @@ parSIdKey = mkPreludeMiscIdUnique 323
funDIdKey
,
valDIdKey
,
dataDIdKey
,
newtypeDIdKey
,
tySynDIdKey
,
classDIdKey
,
instanceDIdKey
,
sigDIdKey
,
forImpDIdKey
,
pragInlDIdKey
,
pragSpecDIdKey
,
pragSpecInlDIdKey
,
familyNoKindDIdKey
,
familyKindDIdKey
,
dataInstDIdKey
,
newtypeInstDIdKey
,
tySynInstDIdKey
::
Unique
dataInstDIdKey
,
newtypeInstDIdKey
,
tySynInstDIdKey
,
infixLDIdKey
,
infixRDIdKey
,
infixNDIdKey
::
Unique
funDIdKey
=
mkPreludeMiscIdUnique
330
valDIdKey
=
mkPreludeMiscIdUnique
331
dataDIdKey
=
mkPreludeMiscIdUnique
332
...
...
@@ -2263,6 +2309,9 @@ familyKindDIdKey = mkPreludeMiscIdUnique 343
dataInstDIdKey
=
mkPreludeMiscIdUnique
344
newtypeInstDIdKey
=
mkPreludeMiscIdUnique
345
tySynInstDIdKey
=
mkPreludeMiscIdUnique
346
infixLDIdKey
=
mkPreludeMiscIdUnique
347
infixRDIdKey
=
mkPreludeMiscIdUnique
348
infixNDIdKey
=
mkPreludeMiscIdUnique
349
-- type Cxt = ...
cxtIdKey
::
Unique
...
...
compiler/hsSyn/Convert.lhs
View file @
ef2491a3
...
...
@@ -154,6 +154,10 @@ cvtDec (TH.SigD nm typ)
; ty' <- cvtType typ
; returnL $ Hs.SigD (TypeSig [nm'] ty') }
cvtDec (TH.InfixD fx nm)
= do { nm' <- vNameL nm
; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= do { prag' <- cvtPragmaD prag
; returnL $ Hs.SigD prag' }
...
...
@@ -250,7 +254,7 @@ cvt_ci_decs :: MsgDoc -> [TH.Dec]
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
= do { decs' <- mapM cvtDec decs
; let (ats', bind_sig_decs') = partitionWith is_
tycl
decs'
; let (ats', bind_sig_decs') = partitionWith is_
fam_inst
decs'
; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
; let (binds', bads) = partitionWith is_bind prob_binds'
; unless (null bads) (failWith (mkBadDecMsg doc bads))
...
...
@@ -302,9 +306,9 @@ cvt_tyinst_hdr cxt tc tys
-- Partitioning declarations
-------------------------------------------------------------------
is_
tycl
:: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
is_
tycl
(L loc (Hs.
TyClD tcd
)) = Left (L loc
tc
d)
is_
tycl decl
= Right decl
is_
fam_inst
:: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
is_
fam_inst
(L loc (Hs.
InstD (FamInstDecl d)
)) = Left (L loc d)
is_
fam_inst decl
= Right decl
is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
...
...
@@ -791,12 +795,11 @@ cvtTvs tvs = mapM cvt_tv tvs
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
; returnL $ UserTyVar nm' placeHolderKind
}
; returnL $ UserTyVar nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs)
placeHolderKind
}
; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
...
...
@@ -877,9 +880,18 @@ cvtKind (ArrowK k1 k2) = do
k2' <- cvtKind k2
returnL (HsFunTy k1' k2')
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe
(HsBndrSig
(LHsKind RdrName))
)
cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just
cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
; return (Just (HsBSig ki' placeHolderBndrs)) }
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
where
cvt_dir TH.InfixL = Hs.InfixL
cvt_dir TH.InfixR = Hs.InfixR
cvt_dir TH.InfixN = Hs.InfixN
-----------------------------------------------------------
...
...
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