Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
ff845ab5
Commit
ff845ab5
authored
Nov 18, 2004
by
igloo
Browse files
[project @ 2004-11-18 00:56:18 by igloo]
Implement FunDeps for TH.
parent
900ca61d
Changes
3
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/deSugar/DsMeta.hs
View file @
ff845ab5
...
...
@@ -28,6 +28,7 @@ import DsMonad
import
qualified
Language.Haskell.TH
as
TH
import
HsSyn
import
Class
(
FunDep
)
import
PrelNames
(
rationalTyConName
,
integerTyConName
,
negateName
)
import
OccName
(
isDataOcc
,
isTvOcc
,
occNameUserString
)
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
...
...
@@ -198,16 +199,17 @@ repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
repTyClD
(
L
loc
(
ClassDecl
{
tcdCtxt
=
cxt
,
tcdLName
=
cls
,
tcdTyVars
=
tvs
,
tcdFDs
=
[]
,
-- We don't understand functional dependencies
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
decls1
}
;
repClass
cxt1
cls1
bndrs1
fds1
decls1
}
;
return
$
Just
(
loc
,
dec
)
}
-- Un-handled cases
...
...
@@ -215,6 +217,19 @@ repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ;
return
Nothing
}
-- represent fundeps
--
repLFunDeps
::
[
Located
(
FunDep
Name
)]
->
DsM
(
Core
[
TH
.
FunDep
])
repLFunDeps
fds
=
do
fds'
<-
mapM
repLFunDep
fds
fdList
<-
coreList
funDepTyConName
fds'
return
fdList
repLFunDep
::
Located
(
FunDep
Name
)
->
DsM
(
Core
TH
.
FunDep
)
repLFunDep
(
L
_
(
xs
,
ys
))
=
do
xs'
<-
mapM
lookupBinder
xs
ys'
<-
mapM
lookupBinder
ys
xs_list
<-
coreList
nameTyConName
xs'
ys_list
<-
coreList
nameTyConName
ys'
repFunDep
xs_list
ys_list
repInstD'
(
L
loc
(
InstDecl
ty
binds
_
))
-- Ignore user pragmas for now
=
do
{
i
<-
addTyVarBinds
tvs
$
\
tv_bndrs
->
...
...
@@ -1147,8 +1162,11 @@ repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, 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
]
repClass
::
Core
TH
.
CxtQ
->
Core
TH
.
Name
->
Core
[
TH
.
Name
]
->
Core
[
TH
.
DecQ
]
->
DsM
(
Core
TH
.
DecQ
)
repClass
(
MkC
cxt
)
(
MkC
cls
)
(
MkC
tvs
)
(
MkC
ds
)
=
rep2
classDName
[
cxt
,
cls
,
tvs
,
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
]
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
sigDName
[
s
,
ty
]
...
...
@@ -1359,6 +1377,8 @@ templateHaskellNames = [
unsafeName
,
safeName
,
threadsafeName
,
-- FunDep
funDepName
,
-- And the tycons
qTyConName
,
nameTyConName
,
patTyConName
,
fieldPatTyConName
,
matchQTyConName
,
...
...
@@ -1366,7 +1386,7 @@ templateHaskellNames = [
decQTyConName
,
conQTyConName
,
strictTypeQTyConName
,
varStrictTypeQTyConName
,
typeQTyConName
,
expTyConName
,
decTyConName
,
typeTyConName
,
matchTyConName
,
clauseTyConName
,
patQTyConName
,
fieldPatQTyConName
,
fieldExpQTyConName
]
fieldPatQTyConName
,
fieldExpQTyConName
,
funDepTyConName
]
tH_SYN_Name
=
mkModuleName
"Language.Haskell.TH.Syntax"
tH_LIB_Name
=
mkModuleName
"Language.Haskell.TH.Lib"
...
...
@@ -1386,16 +1406,17 @@ thFun = mk_known_key_name thSyn OccName.varName
thTc
=
mk_known_key_name
thSyn
OccName
.
tcName
-------------------- TH.Syntax -----------------------
qTyConName
=
thTc
FSLIT
(
"Q"
)
qTyConKey
nameTyConName
=
thTc
FSLIT
(
"Name"
)
nameTyConKey
fieldExpTyConName
=
thTc
FSLIT
(
"FieldExp"
)
fieldExpTyConKey
patTyConName
=
thTc
FSLIT
(
"Pat"
)
patTyConKey
fieldPatTyConName
=
thTc
FSLIT
(
"FieldPat"
)
fieldPatTyConKey
expTyConName
=
thTc
FSLIT
(
"Exp"
)
expTyConKey
decTyConName
=
thTc
FSLIT
(
"Dec"
)
decTyConKey
typeTyConName
=
thTc
FSLIT
(
"Type"
)
typeTyConKey
matchTyConName
=
thTc
FSLIT
(
"Match"
)
matchTyConKey
clauseTyConName
=
thTc
FSLIT
(
"Clause"
)
clauseTyConKey
qTyConName
=
thTc
FSLIT
(
"Q"
)
qTyConKey
nameTyConName
=
thTc
FSLIT
(
"Name"
)
nameTyConKey
fieldExpTyConName
=
thTc
FSLIT
(
"FieldExp"
)
fieldExpTyConKey
patTyConName
=
thTc
FSLIT
(
"Pat"
)
patTyConKey
fieldPatTyConName
=
thTc
FSLIT
(
"FieldPat"
)
fieldPatTyConKey
expTyConName
=
thTc
FSLIT
(
"Exp"
)
expTyConKey
decTyConName
=
thTc
FSLIT
(
"Dec"
)
decTyConKey
typeTyConName
=
thTc
FSLIT
(
"Type"
)
typeTyConKey
matchTyConName
=
thTc
FSLIT
(
"Match"
)
matchTyConKey
clauseTyConName
=
thTc
FSLIT
(
"Clause"
)
clauseTyConKey
funDepTyConName
=
thTc
FSLIT
(
"FunDep"
)
funDepTyConKey
returnQName
=
thFun
FSLIT
(
"returnQ"
)
returnQIdKey
bindQName
=
thFun
FSLIT
(
"bindQ"
)
bindQIdKey
...
...
@@ -1533,6 +1554,9 @@ unsafeName = libFun FSLIT("unsafe") unsafeIdKey
safeName
=
libFun
FSLIT
(
"safe"
)
safeIdKey
threadsafeName
=
libFun
FSLIT
(
"threadsafe"
)
threadsafeIdKey
-- data FunDep = ...
funDepName
=
libFun
FSLIT
(
"funDep"
)
funDepIdKey
matchQTyConName
=
libTc
FSLIT
(
"MatchQ"
)
matchQTyConKey
clauseQTyConName
=
libTc
FSLIT
(
"ClauseQ"
)
clauseQTyConKey
expQTyConName
=
libTc
FSLIT
(
"ExpQ"
)
expQTyConKey
...
...
@@ -1571,6 +1595,7 @@ nameTyConKey = mkPreludeTyConUnique 118
patQTyConKey
=
mkPreludeTyConUnique
119
fieldPatQTyConKey
=
mkPreludeTyConUnique
120
fieldExpQTyConKey
=
mkPreludeTyConUnique
121
funDepTyConKey
=
mkPreludeTyConUnique
122
-- IdUniques available: 200-399
-- If you want to change this, make sure you check in PrelNames
...
...
@@ -1708,3 +1733,6 @@ unsafeIdKey = mkPreludeMiscIdUnique 305
safeIdKey
=
mkPreludeMiscIdUnique
306
threadsafeIdKey
=
mkPreludeMiscIdUnique
307
-- data FunDep = ...
funDepIdKey
=
mkPreludeMiscIdUnique
320
ghc/compiler/hsSyn/Convert.lhs
View file @
ff845ab5
...
...
@@ -14,6 +14,7 @@ import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
import HsSyn as Hs
import qualified Class (FunDep)
import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
import Module ( ModuleName, mkModuleName )
import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
...
...
@@ -95,10 +96,13 @@ cvt_top (NewtypeD ctxt tc tvs constr derivs)
Nothing [mk_con constr]
(mk_derivs derivs))
cvt_top (ClassD ctxt cl tvs decs)
= Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs)
noFunDeps sigs
binds)
cvt_top (ClassD ctxt cl tvs fds decs)
= Left $ TyClD $ mkClassDecl (cvt_context ctxt,
noLoc (tconName cl),
cvt_tvs tvs)
(map (noLoc . cvt_fundep) fds)
sigs
binds
where
(binds,sigs) = cvtBindsAndSigs decs
...
...
@@ -133,6 +137,9 @@ cvt_top (ForeignD (ExportF callconv as nm typ))
CCall -> CCallConv
StdCall -> StdCallConv
cvt_fundep :: FunDep -> Class.FunDep RdrName
cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
parse_ccall_impent nm s
= case lex_ccall_impent s of
...
...
@@ -175,7 +182,6 @@ lex_ccall_impent xs = case span is_valid xs of
noContext = noLoc []
noExistentials = []
noFunDeps = []
-------------------------------------------------------------------
convertToHsExpr :: TH.Exp -> LHsExpr RdrName
...
...
ghc/compiler/typecheck/TcSplice.lhs
View file @
ff845ab5
...
...
@@ -43,7 +43,7 @@ import Var ( Id, TyVar, idType )
import Module ( moduleUserString, mkModuleName )
import TcRnMonad
import IfaceEnv ( lookupOrig )
import Class ( Class, classBigSig )
import Class ( Class, class
Extra
BigSig )
import TyCon ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn,
isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
...
...
@@ -608,9 +608,10 @@ reifyClass :: Class -> TcM TH.Dec
reifyClass cls
= do { cxt <- reifyCxt theta
; ops <- mapM reify_op op_stuff
; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) ops) }
; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs)
fds'
ops) }
where
(tvs, theta, _, op_stuff) = classBigSig cls
(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) }
...
...
@@ -629,6 +630,9 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
reifyTypes = mapM reifyType
reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyTyVars :: [TyVar] -> [TH.Name]
reifyTyVars = map reifyName
...
...
Write
Preview
Supports
Markdown
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