X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=92918a2f4320413aae60a2410c45f398c4803868;hp=bba9d9a07da50814d78f5958d520faaa0f5b9a9c;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hpb=427ce38d4b21c97d32b7c41dfe2cd9d968ef4a34 diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index bba9d9a..92918a2 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 @@ -76,7 +77,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,24 +199,37 @@ 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 -repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ; +repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ; return Nothing } - where - msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") + +-- 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 -> @@ -266,38 +280,54 @@ repSafety PlayRisky = rep2 unsafeName [] repSafety (PlaySafe False) = rep2 safeName [] repSafety (PlaySafe True) = rep2 threadsafeName [] +ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") + ------------------------------------------------------- -- Constructors ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) repC (L loc (ConDecl con [] (L _ []) details)) - = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] + = 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 ------------------------------------------------------- -repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name]) +repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name]) repDerivs Nothing = coreList nameTyConName [] -repDerivs (Just (L _ ctxt)) +repDerivs (Just ctxt) = do { strs <- mapM rep_deriv ctxt ; coreList nameTyConName strs } where - rep_deriv :: LHsPred Name -> DsM (Core TH.Name) + rep_deriv :: LHsType Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form - rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls - rep_deriv other = panic "rep_deriv" + rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls + rep_deriv other = panic "rep_deriv" ------------------------------------------------------- @@ -421,7 +451,7 @@ repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) repTy (HsParTy t) = repLTy t repTy (HsNumTy i) = panic "DsMeta.repTy: Can't represent number types (for generics)" -repTy (HsPredTy pred) = repLPred pred +repTy (HsPredTy pred) = repPred pred repTy (HsKindSig ty kind) = panic "DsMeta.repTy: Can't represent explicit kind signatures yet" @@ -455,7 +485,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) = @@ -470,9 +500,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 @@ -541,7 +571,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 @@ -552,7 +582,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 @@ -566,20 +596,28 @@ repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [L _ (ResultStmt e)])] = do {a <- repLE e; repNormal a } repGuards other - = do { zs <- mapM process other; - repGuarded (nonEmptyCoreList (map corePair zs)) } + = do { zs <- mapM process other; + let {(xs, ys) = unzip zs}; + gd <- repGuarded (nonEmptyCoreList ys); + wrapGenSyns (concat xs) gd } where + process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) + process (L _ (GRHS [])) = panic "No guards in guarded body" process (L _ (GRHS [L _ (ExprStmt e1 ty), L _ (ResultStmt e2)])) - = do { x <- repLE e1; y <- repLE e2; return (x, y) } - process other = panic "Non Haskell 98 guarded body" - -repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp]) + = do { x <- repLNormalGE e1 e2; + return ([], x) } + process (L _ (GRHS ss)) + = do (gs, ss') <- repLSts ss + g <- repPatGE (nonEmptyCoreList ss') + return (gs, g) + +repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp]) repFields flds = do fnames <- mapM lookupLOcc (map fst flds) es <- mapM repLE (map snd flds) - fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es - coreList fieldExpTyConName fs + fs <- zipWithM repFieldExp fnames es + coreList fieldExpQTyConName fs ----------------------------------------------------------------------------- @@ -633,6 +671,7 @@ repSts (ExprStmt e ty : ss) = ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } +repSts [] = panic "repSts ran out of statements" repSts other = panic "Exotic Stmt in meta brackets" @@ -679,26 +718,28 @@ 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 - ; p <- repPvar fn' - ; ans <- repVal p guardcore wherecore - ; return (loc, ans) } + ; fn' <- lookupLBinder fn + ; p <- repPvar fn' + ; ans <- repVal p guardcore wherecore + ; 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) - ; ans <- repVal patcore guardcore wherecore - ; return (loc, ans) } + ; ans <- repVal patcore guardcore wherecore + ; ans' <- wrapGenSyns ss ans + ; return (loc, ans') } rep_bind (L loc (VarBind v e)) = do { v' <- lookupBinder v @@ -734,7 +775,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 ( @@ -752,14 +793,14 @@ repLambda z = panic "Can't represent a guarded lambda in Template Haskell" -- variable should already appear in the environment. -- Process a list of patterns -repLPs :: [LPat Name] -> DsM (Core [TH.Pat]) +repLPs :: [LPat Name] -> DsM (Core [TH.PatQ]) repLPs ps = do { ps' <- mapM repLP ps ; - coreList patTyConName ps' } + coreList patQTyConName ps' } -repLP :: LPat Name -> DsM (Core TH.Pat) +repLP :: LPat Name -> DsM (Core TH.PatQ) repLP (L _ p) = repP p -repP :: Pat Name -> DsM (Core TH.Pat) +repP :: Pat Name -> DsM (Core TH.PatQ) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } @@ -775,12 +816,15 @@ repP (ConPatIn dc details) RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) ; ps <- sequence $ map repLP (map snd pairs) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps - ; fps' <- coreList fieldPatTyConName fps + ; fps' <- coreList fieldPatQTyConName fps ; repPrec con_str fps' } - InfixCon p1 p2 -> do { qs <- repLPs [p1,p2]; repPcon con_str qs } + InfixCon p1 p2 -> do { p1' <- repLP p1; + p2' <- repLP p2; + repPinfix p1' con_str p2' } } repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))" repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a } +repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' } repP other = panic "Exotic pattern inside meta brackets" ---------------------------------------------------------- @@ -953,33 +997,39 @@ rep2 n xs = do { id <- dsLookupGlobalId n -- %********************************************************************* --------------- Patterns ----------------- -repPlit :: Core TH.Lit -> DsM (Core TH.Pat) +repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) repPlit (MkC l) = rep2 litPName [l] -repPvar :: Core TH.Name -> DsM (Core TH.Pat) +repPvar :: Core TH.Name -> DsM (Core TH.PatQ) repPvar (MkC s) = rep2 varPName [s] -repPtup :: Core [TH.Pat] -> DsM (Core TH.Pat) +repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPtup (MkC ps) = rep2 tupPName [ps] -repPcon :: Core TH.Name -> Core [TH.Pat] -> DsM (Core TH.Pat) +repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] -repPrec :: Core TH.Name -> Core [(TH.Name,TH.Pat)] -> DsM (Core TH.Pat) +repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ) repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] -repPtilde :: Core TH.Pat -> DsM (Core TH.Pat) +repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) +repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] + +repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ) repPtilde (MkC p) = rep2 tildePName [p] -repPaspat :: Core TH.Name -> Core TH.Pat -> DsM (Core TH.Pat) +repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] -repPwild :: DsM (Core TH.Pat) +repPwild :: DsM (Core TH.PatQ) repPwild = rep2 wildPName [] -repPlist :: Core [TH.Pat] -> DsM (Core TH.Pat) +repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPlist (MkC ps) = rep2 listPName [ps] +repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) +repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str @@ -997,7 +1047,7 @@ repLit (MkC c) = rep2 litEName [c] repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repApp (MkC x) (MkC y) = rep2 appEName [x,y] -repLam :: Core [TH.Pat] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) +repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) @@ -1024,12 +1074,15 @@ repListExp (MkC es) = rep2 listEName [es] repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] -repRecCon :: Core TH.Name -> Core [TH.FieldExp]-> DsM (Core TH.ExpQ) -repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs] +repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ) +repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] -repRecUpd :: Core TH.ExpQ -> Core [TH.FieldExp] -> DsM (Core TH.ExpQ) +repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ) repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] +repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp)) +repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] + repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] @@ -1040,14 +1093,26 @@ repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] ------------ Right hand sides (guarded expressions) ---- -repGuarded :: Core [(TH.ExpQ, TH.ExpQ)] -> DsM (Core TH.BodyQ) +repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ) repGuarded (MkC pairs) = rep2 guardedBName [pairs] repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) repNormal (MkC e) = rep2 normalBName [e] +------------ Guards ---- +repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repLNormalGE g e = do g' <- repLE g + e' <- repLE e + repNormalGE g' e' + +repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] + +repPatGE :: Core [TH.StmtQ] -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repPatGE (MkC ss) = rep2 patGEName [ss] + ------------- Stmts ------------------- -repBindSt :: Core TH.Pat -> Core TH.ExpQ -> DsM (Core TH.StmtQ) +repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ) repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ) @@ -1070,14 +1135,14 @@ repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.Ex repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] ------------ Match and Clause Tuples ----------- -repMatch :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ) +repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ) repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] -repClause :: Core [TH.Pat] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ) +repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ) repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] -------------- Dec ----------------------------- -repVal :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) +repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) @@ -1097,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] @@ -1231,7 +1299,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))) @@ -1265,8 +1333,8 @@ templateHaskellNames = [ charLName, stringLName, integerLName, intPrimLName, floatPrimLName, doublePrimLName, rationalLName, -- Pat - litPName, varPName, tupPName, conPName, tildePName, - asPName, wildPName, recPName, listPName, + litPName, varPName, tupPName, conPName, tildePName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, -- FieldPat fieldPatName, -- Match @@ -1283,6 +1351,8 @@ templateHaskellNames = [ fieldExpName, -- Body guardedBName, normalBName, + -- Guard + normalGEName, patGEName, -- Stmt bindSName, letSName, noBindSName, parSName, -- Dec @@ -1293,7 +1363,7 @@ templateHaskellNames = [ -- Strict isStrictName, notStrictName, -- Con - normalCName, recCName, infixCName, + normalCName, recCName, infixCName, forallCName, -- StrictType strictTypeName, -- VarStrictType @@ -1307,13 +1377,16 @@ templateHaskellNames = [ unsafeName, safeName, threadsafeName, + -- FunDep + funDepName, -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, matchTyConName, clauseTyConName] + typeTyConName, matchTyConName, clauseTyConName, patQTyConName, + fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax" tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib" @@ -1333,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 @@ -1371,11 +1445,13 @@ litPName = libFun FSLIT("litP") litPIdKey varPName = libFun FSLIT("varP") varPIdKey tupPName = libFun FSLIT("tupP") tupPIdKey conPName = libFun FSLIT("conP") conPIdKey +infixPName = libFun FSLIT("infixP") infixPIdKey tildePName = libFun FSLIT("tildeP") tildePIdKey asPName = libFun FSLIT("asP") asPIdKey wildPName = libFun FSLIT("wildP") wildPIdKey recPName = libFun FSLIT("recP") recPIdKey listPName = libFun FSLIT("listP") listPIdKey +sigPName = libFun FSLIT("sigP") sigPIdKey -- type FieldPat = ... fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey @@ -1420,6 +1496,10 @@ fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey guardedBName = libFun FSLIT("guardedB") guardedBIdKey normalBName = libFun FSLIT("normalB") normalBIdKey +-- data Guard = ... +normalGEName = libFun FSLIT("normalGE") normalGEIdKey +patGEName = libFun FSLIT("patGE") patGEIdKey + -- data Stmt = ... bindSName = libFun FSLIT("bindS") bindSIdKey letSName = libFun FSLIT("letS") letSIdKey @@ -1448,6 +1528,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 @@ -1473,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 @@ -1482,8 +1566,11 @@ conQTyConName = libTc FSLIT("ConQ") conQTyConKey strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey +fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey +patQTyConName = libTc FSLIT("PatQ") patQTyConKey +fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey --- TyConUniques available: 100-119 +-- TyConUniques available: 100-129 -- Check in PrelNames if you want to change this expTyConKey = mkPreludeTyConUnique 100 @@ -1504,7 +1591,11 @@ varStrictTypeQTyConKey = mkPreludeTyConUnique 114 strictTypeQTyConKey = mkPreludeTyConUnique 115 fieldExpTyConKey = mkPreludeTyConUnique 116 fieldPatTyConKey = mkPreludeTyConUnique 117 -nameTyConKey = mkPreludeTyConUnique 118 +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 @@ -1535,11 +1626,13 @@ litPIdKey = mkPreludeMiscIdUnique 220 varPIdKey = mkPreludeMiscIdUnique 221 tupPIdKey = mkPreludeMiscIdUnique 222 conPIdKey = mkPreludeMiscIdUnique 223 +infixPIdKey = mkPreludeMiscIdUnique 312 tildePIdKey = mkPreludeMiscIdUnique 224 asPIdKey = mkPreludeMiscIdUnique 225 wildPIdKey = mkPreludeMiscIdUnique 226 recPIdKey = mkPreludeMiscIdUnique 227 listPIdKey = mkPreludeMiscIdUnique 228 +sigPIdKey = mkPreludeMiscIdUnique 229 -- type FieldPat = ... fieldPatIdKey = mkPreludeMiscIdUnique 230 @@ -1582,6 +1675,10 @@ fieldExpIdKey = mkPreludeMiscIdUnique 265 guardedBIdKey = mkPreludeMiscIdUnique 266 normalBIdKey = mkPreludeMiscIdUnique 267 +-- data Guard = ... +normalGEIdKey = mkPreludeMiscIdUnique 310 +patGEIdKey = mkPreludeMiscIdUnique 311 + -- data Stmt = ... bindSIdKey = mkPreludeMiscIdUnique 268 letSIdKey = mkPreludeMiscIdUnique 269 @@ -1610,6 +1707,7 @@ notStrictKey = mkPreludeMiscIdUnique 282 normalCIdKey = mkPreludeMiscIdUnique 283 recCIdKey = mkPreludeMiscIdUnique 284 infixCIdKey = mkPreludeMiscIdUnique 285 +forallCIdKey = mkPreludeMiscIdUnique 288 -- type StrictType = ... strictTKey = mkPreludeMiscIdUnique 286 @@ -1635,3 +1733,6 @@ unsafeIdKey = mkPreludeMiscIdUnique 305 safeIdKey = mkPreludeMiscIdUnique 306 threadsafeIdKey = mkPreludeMiscIdUnique 307 +-- data FunDep = ... +funDepIdKey = mkPreludeMiscIdUnique 320 +