From ff845ab59d1d465d874d3908fd0cdd61b8594da2 Mon Sep 17 00:00:00 2001 From: igloo Date: Thu, 18 Nov 2004 00:56:25 +0000 Subject: [PATCH] [project @ 2004-11-18 00:56:18 by igloo] Implement FunDeps for TH. --- ghc/compiler/deSugar/DsMeta.hs | 58 ++++++++++++++++++++++++++--------- ghc/compiler/hsSyn/Convert.lhs | 16 +++++++--- ghc/compiler/typecheck/TcSplice.lhs | 10 ++++-- 3 files changed, 61 insertions(+), 23 deletions(-) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 71a17b3..92918a2 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -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 + diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 8b4abaf..7343a8b 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index a9d632e..31dfd31 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -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 -- 1.7.10.4