Skip to content

GitLab

Commit ff845ab5 authored by igloo's avatar igloo
Browse files
Options

[project @ 2004-11-18 00:56:18 by igloo] 

Implement FunDeps for TH.
parent 900ca61d
Hide whitespace changes
Inline Side-by-side
Showing with 61 additions and 23 deletions
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, classExtraBigSig )
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment