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
5e5a08eb
Commit
5e5a08eb
authored
Mar 19, 2009
by
chak@cse.unsw.edu.au.
Browse files
Template Haskell: support for type family declarations
parent
2c8d42f3
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMeta.hs
View file @
5e5a08eb
...
...
@@ -64,6 +64,7 @@ import Outputable
import
Bag
import
FastString
import
ForeignCall
import
MonadUtils
import
Data.Maybe
import
Control.Monad
...
...
@@ -138,11 +139,13 @@ repTopDs group
groupBinders
::
HsGroup
Name
->
[
Located
Name
]
groupBinders
(
HsGroup
{
hs_valds
=
val_decls
,
hs_tyclds
=
tycl_decls
,
hs_fords
=
foreign_decls
})
hs_instds
=
inst_decls
,
hs_fords
=
foreign_decls
})
-- Collect the binders of a Group
=
collectHsValBinders
val_decls
++
[
n
|
d
<-
tycl_decls
,
n
<-
tyClDeclNames
(
unLoc
d
)]
++
[
n
|
d
<-
tycl_decls
++
assoc_tycl_decls
,
n
<-
tyClDeclNames
(
unLoc
d
)]
++
[
n
|
L
_
(
ForeignImport
n
_
_
)
<-
foreign_decls
]
where
assoc_tycl_decls
=
concat
[
ats
|
L
_
(
InstDecl
_
_
_
ats
)
<-
inst_decls
]
{- Note [Binders and occurrences]
...
...
@@ -171,59 +174,99 @@ in repTyClD and repC.
repTyClD
::
LTyClDecl
Name
->
DsM
(
Maybe
(
SrcSpan
,
Core
TH
.
DecQ
))
repTyClD
tydecl
@
(
L
_
(
TyFamily
{}))
=
repTyFamily
tydecl
addTyVarBinds
repTyClD
(
L
loc
(
TyData
{
tcdND
=
DataType
,
tcdCtxt
=
cxt
,
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdCons
=
cons
,
tcdDerivs
=
mb_derivs
}))
=
do
{
tc1
<-
lookupLOcc
tc
;
-- See note [Binders and occurrences]
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
cxt1
<-
repLContext
cxt
;
cons1
<-
mapM
repC
cons
;
cons2
<-
coreList
conQTyConName
cons1
;
derivs1
<-
repDerivs
mb_derivs
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repData
cxt1
tc1
bndrs1
cons2
derivs1
}
;
return
$
Just
(
loc
,
dec
)
}
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
->
do
{
cxt1
<-
repLContext
cxt
;
opt_tys1
<-
maybeMapM
repLTys
opt_tys
-- only for family insts
;
opt_tys2
<-
maybeMapM
(
coreList
typeQTyConName
)
opt_tys1
;
cons1
<-
mapM
repC
cons
;
cons2
<-
coreList
conQTyConName
cons1
;
derivs1
<-
repDerivs
mb_derivs
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repData
cxt1
tc1
bndrs1
opt_tys2
cons2
derivs1
}
;
return
$
Just
(
loc
,
dec
)
}
repTyClD
(
L
loc
(
TyData
{
tcdND
=
NewType
,
tcdCtxt
=
cxt
,
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdCons
=
[
con
],
tcdDerivs
=
mb_derivs
}))
=
do
{
tc1
<-
lookupLOcc
tc
;
-- See note [Binders and occurrences]
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
cxt1
<-
repLContext
cxt
;
con1
<-
repC
con
;
derivs1
<-
repDerivs
mb_derivs
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repNewtype
cxt1
tc1
bndrs1
con1
derivs1
}
;
return
$
Just
(
loc
,
dec
)
}
repTyClD
(
L
loc
(
TySynonym
{
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdSynRhs
=
ty
}))
=
do
{
tc1
<-
lookupLOcc
tc
;
-- See note [Binders and occurrences]
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
ty1
<-
repLTy
ty
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repTySyn
tc1
bndrs1
ty1
}
;
return
(
Just
(
loc
,
dec
))
}
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdTyPats
=
opt_tys
,
tcdCons
=
[
con
],
tcdDerivs
=
mb_derivs
}))
=
do
{
tc1
<-
lookupLOcc
tc
-- See note [Binders and occurrences]
;
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
cxt1
<-
repLContext
cxt
;
opt_tys1
<-
maybeMapM
repLTys
opt_tys
-- only for family insts
;
opt_tys2
<-
maybeMapM
(
coreList
typeQTyConName
)
opt_tys1
;
con1
<-
repC
con
;
derivs1
<-
repDerivs
mb_derivs
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repNewtype
cxt1
tc1
bndrs1
opt_tys2
con1
derivs1
}
;
return
$
Just
(
loc
,
dec
)
}
repTyClD
(
L
loc
(
TySynonym
{
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdTyPats
=
opt_tys
,
tcdSynRhs
=
ty
}))
=
do
{
tc1
<-
lookupLOcc
tc
-- See note [Binders and occurrences]
;
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
opt_tys1
<-
maybeMapM
repLTys
opt_tys
-- only for family insts
;
opt_tys2
<-
maybeMapM
(
coreList
typeQTyConName
)
opt_tys1
;
ty1
<-
repLTy
ty
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repTySyn
tc1
bndrs1
opt_tys2
ty1
}
;
return
(
Just
(
loc
,
dec
))
}
repTyClD
(
L
loc
(
ClassDecl
{
tcdCtxt
=
cxt
,
tcdLName
=
cls
,
tcdTyVars
=
tvs
,
tcdFDs
=
fds
,
tcdSigs
=
sigs
,
tcdMeths
=
meth_binds
}))
=
do
{
cls1
<-
lookupLOcc
cls
;
-- See note [Binders and occurrences]
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
cxt1
<-
repLContext
cxt
;
sigs1
<-
rep_sigs
sigs
;
binds1
<-
rep_binds
meth_binds
;
fds1
<-
repLFunDeps
fds
;
decls1
<-
coreList
decQTyConName
(
sigs1
++
binds1
)
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repClass
cxt1
cls1
bndrs1
fds1
decls1
}
;
return
$
Just
(
loc
,
dec
)
}
tcdTyVars
=
tvs
,
tcdFDs
=
fds
,
tcdSigs
=
sigs
,
tcdMeths
=
meth_binds
,
tcdATs
=
ats
}))
=
do
{
cls1
<-
lookupLOcc
cls
-- See note [Binders and occurrences]
;
dec
<-
addTyVarBinds
tvs
$
\
bndrs
->
do
{
cxt1
<-
repLContext
cxt
;
sigs1
<-
rep_sigs
sigs
;
binds1
<-
rep_binds
meth_binds
;
fds1
<-
repLFunDeps
fds
;
ats1
<-
repLAssocFamilys
ats
;
decls1
<-
coreList
decQTyConName
(
ats1
++
sigs1
++
binds1
)
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repClass
cxt1
cls1
bndrs1
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
}
-- 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.
--
repTyFamily
::
LTyClDecl
Name
->
ProcessTyVarBinds
TH
.
Dec
->
DsM
(
Maybe
(
SrcSpan
,
Core
TH
.
DecQ
))
repTyFamily
(
L
loc
(
TyFamily
{
tcdFlavour
=
flavour
,
tcdLName
=
tc
,
tcdTyVars
=
tvs
,
tcdKind
=
_kind
}))
tyVarBinds
=
do
{
tc1
<-
lookupLOcc
tc
-- See note [Binders and occurrences]
;
dec
<-
tyVarBinds
tvs
$
\
bndrs
->
do
{
flav
<-
repFamilyFlavour
flavour
;
bndrs1
<-
coreList
nameTyConName
bndrs
;
repFamily
flav
tc1
bndrs1
}
;
return
$
Just
(
loc
,
dec
)
}
repTyFamily
_
_
=
panic
"DsMeta.repTyFamily: internal error"
-- represent fundeps
--
repLFunDeps
::
[
Located
(
FunDep
Name
)]
->
DsM
(
Core
[
TH
.
FunDep
])
...
...
@@ -238,22 +281,49 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
ys_list
<-
coreList
nameTyConName
ys'
repFunDep
xs_list
ys_list
-- represent family declaration flavours
--
repFamilyFlavour
::
FamilyFlavour
->
DsM
(
Core
TH
.
FamFlavour
)
repFamilyFlavour
TypeFamily
=
rep2
typeFamName
[]
repFamilyFlavour
DataFamily
=
rep2
dataFamName
[]
-- represent associated family declarations
--
repLAssocFamilys
::
[
LTyClDecl
Name
]
->
DsM
[
Core
TH
.
DecQ
]
repLAssocFamilys
=
mapM
repLAssocFamily
where
repLAssocFamily
tydecl
@
(
L
_
(
TyFamily
{}))
=
liftM
(
snd
.
fromJust
)
$
repTyFamily
tydecl
lookupTyVarBinds
repLAssocFamily
tydecl
=
failWithDs
msg
where
msg
=
ptext
(
sLit
"Illegal associated declaration in class:"
)
<+>
ppr
tydecl
-- represent associated family instances
--
repLAssocFamInst
::
[
LTyClDecl
Name
]
->
DsM
[
Core
TH
.
DecQ
]
repLAssocFamInst
=
liftM
de_loc
.
mapMaybeM
repTyClD
-- represent instance declarations
--
repInstD'
::
LInstDecl
Name
->
DsM
(
SrcSpan
,
Core
TH
.
DecQ
)
repInstD'
(
L
loc
(
InstDecl
ty
binds
_
_
))
-- Ignore user pragmas for now
=
do
{
i
<-
addTyVarBinds
tvs
$
\
_
->
-- We must bring the type variables into scope, so their
occurrences
-- don't fail,
even though the binders don't
appear in the resulting
--
data structure
do
{
cxt1
<-
repContext
cxt
repInstD'
(
L
loc
(
InstDecl
ty
binds
_
ats
))
-- Ignore user pragmas for now
=
do
{
i
<-
addTyVarBinds
tvs
$
\
_
->
-- We must bring the type variables into scope, so their
--
occurrences
don't fail, even though the binders don't
-- appear in the resulting
data structure
do
{
cxt1
<-
repContext
cxt
;
inst_ty1
<-
repPred
(
HsClassP
cls
tys
)
;
ss
<-
mkGenSyms
(
collectHsBindBinders
binds
)
;
binds1
<-
addBinds
ss
(
rep_binds
binds
)
;
decls1
<-
coreList
decQTyConName
binds1
;
ats1
<-
repLAssocFamInst
ats
;
decls1
<-
coreList
decQTyConName
(
ats1
++
binds1
)
;
decls2
<-
wrapNongenSyms
ss
decls1
-- wrapNon
G
enSyms: do not clone the class op names!
-- wrapNon
g
enSyms: do not clone the class op names!
-- They must be called 'op' etc, not 'op34'
;
repInst
cxt1
inst_ty1
decls2
}
;
repInst
cxt1
inst_ty1
(
decls2
)
}
;
return
(
loc
,
i
)}
where
(
tvs
,
cxt
,
cls
,
tys
)
=
splitHsInstDeclTy
(
unLoc
ty
)
...
...
@@ -370,13 +440,20 @@ rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
-- Types
-------------------------------------------------------
-- We process type variable bindings in two ways, either by generating fresh
-- names or looking up existing names. The difference is crucial for type
-- families, depending on whether they are associated or not.
--
type
ProcessTyVarBinds
a
=
[
LHsTyVarBndr
Name
]
-- the binders to be added
->
([
Core
TH
.
Name
]
->
DsM
(
Core
(
TH
.
Q
a
)))
-- action in the ext env
->
DsM
(
Core
(
TH
.
Q
a
))
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
-- meta environment and gets the *new* names on Core-level as an argument
--
addTyVarBinds
::
[
LHsTyVarBndr
Name
]
-- the binders to be added
->
([
Core
TH
.
Name
]
->
DsM
(
Core
(
TH
.
Q
a
)))
-- action in the ext env
->
DsM
(
Core
(
TH
.
Q
a
))
addTyVarBinds
::
ProcessTyVarBinds
a
addTyVarBinds
tvs
m
=
do
let
names
=
map
(
hsTyVarName
.
unLoc
)
tvs
...
...
@@ -386,6 +463,16 @@ addTyVarBinds tvs m =
m
bndrs
wrapGenSyns
freshNames
term
-- Look up a list of type variables; the computations passed as the second
-- argument gets the *new* names on Core-level as an argument
--
lookupTyVarBinds
::
ProcessTyVarBinds
a
lookupTyVarBinds
tvs
m
=
do
let
names
=
map
(
hsTyVarName
.
unLoc
)
tvs
bndrs
<-
mapM
lookupBinder
names
m
bndrs
-- represent a type context
--
repLContext
::
LHsContext
Name
->
DsM
(
Core
TH
.
CxtQ
)
...
...
@@ -1185,16 +1272,29 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
repFun
::
Core
TH
.
Name
->
Core
[
TH
.
ClauseQ
]
->
DsM
(
Core
TH
.
DecQ
)
repFun
(
MkC
nm
)
(
MkC
b
)
=
rep2
funDName
[
nm
,
b
]
repData
::
Core
TH
.
CxtQ
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Core
[
TH
.
ConQ
]
->
Core
[
TH
.
Name
]
->
DsM
(
Core
TH
.
DecQ
)
repData
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
tvs
)
(
MkC
cons
)
(
MkC
derivs
)
=
rep2
dataDName
[
cxt
,
nm
,
tvs
,
cons
,
derivs
]
repNewtype
::
Core
TH
.
CxtQ
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Core
TH
.
ConQ
->
Core
[
TH
.
Name
]
->
DsM
(
Core
TH
.
DecQ
)
repNewtype
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
tvs
)
(
MkC
con
)
(
MkC
derivs
)
=
rep2
newtypeDName
[
cxt
,
nm
,
tvs
,
con
,
derivs
]
repTySyn
::
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Core
TH
.
TypeQ
->
DsM
(
Core
TH
.
DecQ
)
repTySyn
(
MkC
nm
)
(
MkC
tvs
)
(
MkC
rhs
)
=
rep2
tySynDName
[
nm
,
tvs
,
rhs
]
repData
::
Core
TH
.
CxtQ
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Maybe
(
Core
[
TH
.
TypeQ
])
->
Core
[
TH
.
ConQ
]
->
Core
[
TH
.
Name
]
->
DsM
(
Core
TH
.
DecQ
)
repData
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
tvs
)
Nothing
(
MkC
cons
)
(
MkC
derivs
)
=
rep2
dataDName
[
cxt
,
nm
,
tvs
,
cons
,
derivs
]
repData
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
_
)
(
Just
(
MkC
tys
))
(
MkC
cons
)
(
MkC
derivs
)
=
rep2
dataInstDName
[
cxt
,
nm
,
tys
,
cons
,
derivs
]
repNewtype
::
Core
TH
.
CxtQ
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Maybe
(
Core
[
TH
.
TypeQ
])
->
Core
TH
.
ConQ
->
Core
[
TH
.
Name
]
->
DsM
(
Core
TH
.
DecQ
)
repNewtype
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
tvs
)
Nothing
(
MkC
con
)
(
MkC
derivs
)
=
rep2
newtypeDName
[
cxt
,
nm
,
tvs
,
con
,
derivs
]
repNewtype
(
MkC
cxt
)
(
MkC
nm
)
(
MkC
_
)
(
Just
(
MkC
tys
))
(
MkC
con
)
(
MkC
derivs
)
=
rep2
newtypeInstDName
[
cxt
,
nm
,
tys
,
con
,
derivs
]
repTySyn
::
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Maybe
(
Core
[
TH
.
TypeQ
])
->
Core
TH
.
TypeQ
->
DsM
(
Core
TH
.
DecQ
)
repTySyn
(
MkC
nm
)
(
MkC
tvs
)
Nothing
(
MkC
rhs
)
=
rep2
tySynDName
[
nm
,
tvs
,
rhs
]
repTySyn
(
MkC
nm
)
(
MkC
_
)
(
Just
(
MkC
tys
))
(
MkC
rhs
)
=
rep2
tySynInstDName
[
nm
,
tys
,
rhs
]
repInst
::
Core
TH
.
CxtQ
->
Core
TH
.
TypeQ
->
Core
[
TH
.
DecQ
]
->
DsM
(
Core
TH
.
DecQ
)
repInst
(
MkC
cxt
)
(
MkC
ty
)
(
MkC
ds
)
=
rep2
instanceDName
[
cxt
,
ty
,
ds
]
...
...
@@ -1202,6 +1302,11 @@ repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
repClass
::
Core
TH
.
CxtQ
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Core
[
TH
.
FunDep
]
->
Core
[
TH
.
DecQ
]
->
DsM
(
Core
TH
.
DecQ
)
repClass
(
MkC
cxt
)
(
MkC
cls
)
(
MkC
tvs
)
(
MkC
fds
)
(
MkC
ds
)
=
rep2
classDName
[
cxt
,
cls
,
tvs
,
fds
,
ds
]
repFamily
::
Core
TH
.
FamFlavour
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
DsM
(
Core
TH
.
DecQ
)
repFamily
(
MkC
flav
)
(
MkC
nm
)
(
MkC
tvs
)
=
rep2
familyDName
[
flav
,
nm
,
tvs
]
repFunDep
::
Core
[
TH
.
Name
]
->
Core
[
TH
.
Name
]
->
DsM
(
Core
TH
.
FunDep
)
repFunDep
(
MkC
xs
)
(
MkC
ys
)
=
rep2
funDepName
[
xs
,
ys
]
...
...
@@ -1408,7 +1513,8 @@ templateHaskellNames = [
bindSName
,
letSName
,
noBindSName
,
parSName
,
-- Dec
funDName
,
valDName
,
dataDName
,
newtypeDName
,
tySynDName
,
classDName
,
instanceDName
,
sigDName
,
forImpDName
,
classDName
,
instanceDName
,
sigDName
,
forImpDName
,
familyDName
,
dataInstDName
,
newtypeInstDName
,
tySynInstDName
,
-- Cxt
cxtName
,
-- Strict
...
...
@@ -1430,6 +1536,8 @@ templateHaskellNames = [
threadsafeName
,
-- FunDep
funDepName
,
-- FamFlavour
typeFamName
,
dataFamName
,
-- And the tycons
qTyConName
,
nameTyConName
,
patTyConName
,
fieldPatTyConName
,
matchQTyConName
,
...
...
@@ -1583,16 +1691,21 @@ parSName = libFun (fsLit "parS") parSIdKey
-- data Dec = ...
funDName
,
valDName
,
dataDName
,
newtypeDName
,
tySynDName
,
classDName
,
instanceDName
,
sigDName
,
forImpDName
::
Name
funDName
=
libFun
(
fsLit
"funD"
)
funDIdKey
valDName
=
libFun
(
fsLit
"valD"
)
valDIdKey
dataDName
=
libFun
(
fsLit
"dataD"
)
dataDIdKey
newtypeDName
=
libFun
(
fsLit
"newtypeD"
)
newtypeDIdKey
tySynDName
=
libFun
(
fsLit
"tySynD"
)
tySynDIdKey
classDName
=
libFun
(
fsLit
"classD"
)
classDIdKey
instanceDName
=
libFun
(
fsLit
"instanceD"
)
instanceDIdKey
sigDName
=
libFun
(
fsLit
"sigD"
)
sigDIdKey
forImpDName
=
libFun
(
fsLit
"forImpD"
)
forImpDIdKey
instanceDName
,
sigDName
,
forImpDName
,
familyDName
,
dataInstDName
,
newtypeInstDName
,
tySynInstDName
::
Name
funDName
=
libFun
(
fsLit
"funD"
)
funDIdKey
valDName
=
libFun
(
fsLit
"valD"
)
valDIdKey
dataDName
=
libFun
(
fsLit
"dataD"
)
dataDIdKey
newtypeDName
=
libFun
(
fsLit
"newtypeD"
)
newtypeDIdKey
tySynDName
=
libFun
(
fsLit
"tySynD"
)
tySynDIdKey
classDName
=
libFun
(
fsLit
"classD"
)
classDIdKey
instanceDName
=
libFun
(
fsLit
"instanceD"
)
instanceDIdKey
sigDName
=
libFun
(
fsLit
"sigD"
)
sigDIdKey
forImpDName
=
libFun
(
fsLit
"forImpD"
)
forImpDIdKey
familyDName
=
libFun
(
fsLit
"familyD"
)
familyDIdKey
dataInstDName
=
libFun
(
fsLit
"dataInstD"
)
dataInstDIdKey
newtypeInstDName
=
libFun
(
fsLit
"newtypeInstD"
)
newtypeInstDIdKey
tySynInstDName
=
libFun
(
fsLit
"tySynInstD"
)
tySynInstDIdKey
-- type Ctxt = ...
cxtName
::
Name
...
...
@@ -1644,6 +1757,11 @@ threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
funDepName
::
Name
funDepName
=
libFun
(
fsLit
"funDep"
)
funDepIdKey
-- data FamFlavour = ...
typeFamName
,
dataFamName
::
Name
typeFamName
=
libFun
(
fsLit
"typeFam"
)
typeFamIdKey
dataFamName
=
libFun
(
fsLit
"dataFam"
)
dataFamIdKey
matchQTyConName
,
clauseQTyConName
,
expQTyConName
,
stmtQTyConName
,
decQTyConName
,
conQTyConName
,
strictTypeQTyConName
,
varStrictTypeQTyConName
,
typeQTyConName
,
fieldExpQTyConName
,
...
...
@@ -1809,7 +1927,8 @@ parSIdKey = mkPreludeMiscIdUnique 271
-- data Dec = ...
funDIdKey
,
valDIdKey
,
dataDIdKey
,
newtypeDIdKey
,
tySynDIdKey
,
classDIdKey
,
instanceDIdKey
,
sigDIdKey
,
forImpDIdKey
::
Unique
classDIdKey
,
instanceDIdKey
,
sigDIdKey
,
forImpDIdKey
,
familyDIdKey
,
dataInstDIdKey
,
newtypeInstDIdKey
,
tySynInstDIdKey
::
Unique
funDIdKey
=
mkPreludeMiscIdUnique
272
valDIdKey
=
mkPreludeMiscIdUnique
273
dataDIdKey
=
mkPreludeMiscIdUnique
274
...
...
@@ -1819,6 +1938,10 @@ classDIdKey = mkPreludeMiscIdUnique 277
instanceDIdKey
=
mkPreludeMiscIdUnique
278
sigDIdKey
=
mkPreludeMiscIdUnique
279
forImpDIdKey
=
mkPreludeMiscIdUnique
297
familyDIdKey
=
mkPreludeMiscIdUnique
340
dataInstDIdKey
=
mkPreludeMiscIdUnique
341
newtypeInstDIdKey
=
mkPreludeMiscIdUnique
342
tySynInstDIdKey
=
mkPreludeMiscIdUnique
343
-- type Cxt = ...
cxtIdKey
::
Unique
...
...
@@ -1870,6 +1993,11 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307
funDepIdKey
::
Unique
funDepIdKey
=
mkPreludeMiscIdUnique
320
-- data FamFlavour = ...
typeFamIdKey
,
dataFamIdKey
::
Unique
typeFamIdKey
=
mkPreludeMiscIdUnique
344
dataFamIdKey
=
mkPreludeMiscIdUnique
345
-- quasiquoting
quoteExpKey
,
quotePatKey
::
Unique
quoteExpKey
=
mkPreludeMiscIdUnique
321
...
...
compiler/hsSyn/Convert.lhs
View file @
5e5a08eb
...
...
@@ -6,13 +6,6 @@
This module converts Template Haskell syntax into HsSyn
\begin{code}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType, thRdrNameGuesses ) where
...
...
@@ -32,6 +25,7 @@ import ForeignCall
import Char
import List
import Unique
import MonadUtils
import ErrUtils
import Bag
import FastString
...
...
@@ -107,15 +101,21 @@ wrapL (CvtM m) = CvtM (\loc -> case m loc of
-------------------------------------------------------------------
cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
cvtTop d@(TH.FunD _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
cvtTop (TH.SigD nm typ) = do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnL $ Hs.SigD (TypeSig nm' ty') }
cvtTop d@(TH.ValD _ _ _)
= do { L loc d' <- cvtBind d
; return (L loc $ Hs.ValD d') }
cvtTop d@(TH.FunD _ _)
= do { L loc d' <- cvtBind d
; return (L loc $ Hs.ValD d') }
cvtTop (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnL $ Hs.SigD (TypeSig nm' ty') }
cvtTop (TySynD tc tvs rhs)
= do { tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
= do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
...
...
@@ -125,7 +125,6 @@ cvtTop (DataD ctxt tc tvs constrs derivs)
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
cvtTop (NewtypeD ctxt tc tvs constr derivs)
= do { stuff <- cvt_tycl_hdr ctxt tc tvs
; con' <- cvtConstr constr
...
...
@@ -135,32 +134,109 @@ cvtTop (NewtypeD ctxt tc tvs constr derivs)
cvtTop (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs') <- cvtBindsAndSigs decs
; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
-- no ATs or docs in TH ^^ ^^
; let (ats, bind_sig_decs) = partition isFamilyD decs
; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
; ats' <- mapM cvtTop ats
; let ats'' = map unTyClD ats'
; returnL $
TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' []
-- no docs in TH ^^
}
where
isFamilyD (FamilyD _ _ _) = True
isFamilyD _ = False
cvtTop (InstanceD tys ty decs)
= do { (binds', sigs') <- cvtBindsAndSigs decs
= do { let (ats, bind_sig_decs) = partition isFamInstD decs
; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
; ats' <- mapM cvtTop ats
; let ats'' = map unTyClD ats'
; ctxt' <- cvtContext tys
; L loc pred' <- cvtPred ty
; inst_ty' <- returnL $
mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
; returnL $ InstD (InstDecl inst_ty' binds' sigs' []
)
-- no ATs in TH ^^
; inst_ty' <- returnL $
mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')
)
; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
}
where
isFamInstD (DataInstD _ _ _ _ _) = True
isFamInstD (NewtypeInstD _ _ _ _ _) = True
isFamInstD (TySynInstD _ _ _) = True
isFamInstD _ = False
cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
cvtTop (FamilyD flav tc tvs)
= do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing)
-- FIXME: kinds
}
where
cvtFamFlavour TypeFam = TypeFamily
cvtFamFlavour DataFam = DataFamily
cvtTop (DataInstD ctxt tc tys constrs derivs)
= do { stuff <- cvt_tyinst_hdr ctxt tc tys
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs')
}
cvtTop (NewtypeInstD ctxt tc tys constr derivs)
= do { stuff <- cvt_tyinst_hdr ctxt tc tys
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs')
}
cvtTop (TySynInstD tc tys rhs)
= do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
-- FIXME: This projection is not nice, but to remove it, cvtTop should be
-- refactored.
unTyClD :: LHsDecl a -> LTyClDecl a
unTyClD (L l (TyClD d)) = L l d
unTyClD _ = panic "Convert.unTyClD: internal error"
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
-> CvtM (LHsContext RdrName
,Located RdrName
,[LHsTyVarBndr RdrName]
,Maybe [LHsType RdrName])
-> CvtM (
LHsContext RdrName
,
Located RdrName
,
[LHsTyVarBndr RdrName]
,
Maybe [LHsType RdrName])
cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', tvs', Nothing) }
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', tvs', Nothing)
}
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName
, Located RdrName
, [LHsTyVarBndr RdrName]
, Maybe [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs <- concatMapM collect tys
; tvs' <- cvtTvs tvs
; tys' <- mapM cvtType tys
; return (cxt', tc', tvs', Just tys')
}
where
collect (ForallT _ _ _)
= failWith $ text "Forall type not allowed as type parameter"
collect (VarT tv) = return [tv]
collect (ConT _) = return []
collect (TupleT _) = return []
collect ArrowT = return []
collect ListT = return []
collect (AppT t1 t2)
= do { tvs1 <- collect t1
; tvs2 <- collect t2
; return $ tvs1 ++ tvs2
}
---------------------------------------------------
-- Data types
...
...
@@ -317,6 +393,7 @@ cvtBindsAndSigs ds
cvtSig :: TH.Dec -> CvtM (LSig RdrName)
cvtSig (TH.SigD nm ty)
= do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
cvtSig _ = panic "Convert.cvtSig: Signature expected"
cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
-- Used only for declarations in a 'let/where' clause,
...
...
@@ -426,6 +503,7 @@ cvtHsDo do_or_lc stmts
= do { stmts' <- cvtStmts stmts
; let body = case last stmts' of
L _ (ExprStmt body _ _) -> body
_ -> panic "Malformed body"
; return $ HsDo do_or_lc (init stmts') body void }
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
...
...
@@ -458,10 +536,17 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
; returnL $ GRHS gs' rhs' }
cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType}
cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType}
cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType }
-- An Integer is like an an (overloaded) '3' in a Haskell source program