X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=150b90e8b4ce19637faabaf9322ac32bed0f30a0;hb=75d52d81c0256e7bd2ae5108fc611224ea08edda;hp=23117b08412c5f74f70c51d184fe99384609fb16;hpb=c92ad29760f7e307bade71ff51ca10563fd6d474;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 23117b0..150b90e 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -22,12 +22,13 @@ module DsMeta( dsBracket, import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit ( dsLit ) -import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr ) +import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr ) 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 @@ -36,7 +37,7 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- ws previously used in this file. import qualified OccName -import Module ( Module, mkModule, mkModuleName, moduleUserString ) +import Module ( Module, mkModule, moduleUserString ) import Id ( Id, mkLocalId ) import OccName ( mkOccFS ) import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, @@ -52,7 +53,6 @@ import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) import Maybe ( catMaybes ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) import BasicTypes ( isBoxed ) -import Packages ( thPackage ) import Outputable import Bag ( bagToList ) import FastString ( unpackFS ) @@ -76,7 +76,7 @@ dsBracket brack splices do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 } {- -------------- Examples -------------------- @@ -198,16 +198,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 +216,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 -> @@ -275,21 +289,29 @@ repC :: LConDecl Name -> DsM (Core TH.ConQ) repC (L loc (ConDecl con [] (L _ []) details)) = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } - +repC (L loc (ConDecl con tvs (L cloc ctxt) details)) + = do { addTyVarBinds tvs $ \bndrs -> do { + c' <- repC (L loc (ConDecl con [] (L cloc []) details)); + ctxt' <- repContext ctxt; + bndrs' <- coreList nameTyConName bndrs; + rep2 forallCName [unC bndrs', unC ctxt', unC c'] + } + } repC (L loc con_decl) = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl)) ; return (panic "DsMeta:repC") } where - +-- gaw 2004 FIX! Need a case for GadtDecl repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) -repBangTy (L _ (BangType str ty)) = do - MkC s <- rep2 strName [] - MkC t <- repLTy ty +repBangTy ty= do + MkC s <- rep2 str [] + MkC t <- repLTy ty' rep2 strictTypeName [s, t] - where strName = case str of - HsNoBang -> notStrictName - other -> isStrictName + where + (str, ty') = case ty of + L _ (HsBangTy _ ty) -> (isStrictName, ty) + other -> (notStrictName, ty) ------------------------------------------------------- -- Deriving clause @@ -462,7 +484,7 @@ repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters" -- HsOverlit can definitely occur repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } -repE (HsLam m) = repLambda m +repE (HsLam (MatchGroup [m] _)) = repLambda m repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (OpApp e1 op fix e2) = @@ -477,9 +499,9 @@ repE (NegApp x nm) = do repE (HsPar x) = repLE x repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase e ms) = do { arg <- repLE e - ; ms2 <- mapM repMatchTup ms - ; repCaseE arg (nonEmptyCoreList ms2) } +repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; repCaseE arg (nonEmptyCoreList ms2) } repE (HsIf x y z) = do a <- repLE x b <- repLE y @@ -548,7 +570,7 @@ repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e) -- Building representations of auxillary structures like Match, Clause, Stmt, repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) = +repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -559,7 +581,7 @@ repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) = ; wrapGenSyns (ss1++ss2) match }}} repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) = +repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -695,7 +717,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))])) +rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _))) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -704,13 +726,13 @@ rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))])) ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind fn infx ms)) +rep_bind (L loc (FunBind fn infx (MatchGroup ms _))) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2))) +rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2)) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -752,7 +774,7 @@ rep_bind (L loc (VarBind v e)) -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name -> DsM (Core TH.ExpQ) -repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _))) +repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] []))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -889,7 +911,7 @@ globalVar name | otherwise = do { MkC occ <- occNameLit name ; MkC uni <- coreIntLit (getKey (getUnique name)) - ; rep2 mkNameUName [occ,uni] } + ; rep2 mkNameLName [occ,uni] } where name_mod = moduleUserString (nameModule name) name_occ = nameOccName name @@ -1139,8 +1161,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] @@ -1273,7 +1298,7 @@ corePair :: (Core a, Core b) -> Core (a,b) corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) coreStringLit :: String -> DsM (Core String) -coreStringLit s = do { z <- mkStringLit s; return(MkC z) } +coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } coreIntLit :: Int -> DsM (Core Int) coreIntLit i = return (MkC (mkIntExpr (fromIntegral i))) @@ -1301,7 +1326,7 @@ templateHaskellNames :: [Name] templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, -- Lit charLName, stringLName, integerLName, intPrimLName, @@ -1337,7 +1362,7 @@ templateHaskellNames = [ -- Strict isStrictName, notStrictName, -- Con - normalCName, recCName, infixCName, + normalCName, recCName, infixCName, forallCName, -- StrictType strictTypeName, -- VarStrictType @@ -1351,6 +1376,8 @@ templateHaskellNames = [ unsafeName, safeName, threadsafeName, + -- FunDep + funDepName, -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, @@ -1358,15 +1385,11 @@ templateHaskellNames = [ decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, patQTyConName, - fieldPatQTyConName, fieldExpQTyConName] - -tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax" -tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib" + fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] thSyn :: Module --- NB: the TH.Syntax module comes from the "template-haskell" package -thSyn = mkModule thPackage tH_SYN_Name -thLib = mkModule thPackage tH_LIB_Name +thSyn = mkModule "Language.Haskell.TH.Syntax" +thLib = mkModule "Language.Haskell.TH.Lib" mk_known_key_name mod space str uniq = mkExternalName uniq mod (mkOccFS space str) @@ -1378,16 +1401,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 @@ -1398,7 +1422,7 @@ mkNameName = thFun FSLIT("mkName") mkNameIdKey mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey -mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey +mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey -------------------- TH.Lib ----------------------- @@ -1499,6 +1523,7 @@ notStrictName = libFun FSLIT("notStrict") notStrictKey normalCName = libFun FSLIT("normalC") normalCIdKey recCName = libFun FSLIT("recC") recCIdKey infixCName = libFun FSLIT("infixC") infixCIdKey +forallCName = libFun FSLIT("forallC") forallCIdKey -- type StrictType = ... strictTypeName = libFun FSLIT("strictType") strictTKey @@ -1524,6 +1549,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 @@ -1562,6 +1590,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 @@ -1575,7 +1604,7 @@ mkNameIdKey = mkPreludeMiscIdUnique 205 mkNameG_vIdKey = mkPreludeMiscIdUnique 206 mkNameG_dIdKey = mkPreludeMiscIdUnique 207 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 -mkNameUIdKey = mkPreludeMiscIdUnique 209 +mkNameLIdKey = mkPreludeMiscIdUnique 209 -- data Lit = ... @@ -1673,6 +1702,7 @@ notStrictKey = mkPreludeMiscIdUnique 282 normalCIdKey = mkPreludeMiscIdUnique 283 recCIdKey = mkPreludeMiscIdUnique 284 infixCIdKey = mkPreludeMiscIdUnique 285 +forallCIdKey = mkPreludeMiscIdUnique 288 -- type StrictType = ... strictTKey = mkPreludeMiscIdUnique 286 @@ -1698,3 +1728,6 @@ unsafeIdKey = mkPreludeMiscIdUnique 305 safeIdKey = mkPreludeMiscIdUnique 306 threadsafeIdKey = mkPreludeMiscIdUnique 307 +-- data FunDep = ... +funDepIdKey = mkPreludeMiscIdUnique 320 +