X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=88b0ba9c8e1b1df2e666a111da7782c7814e51cc;hb=04feba252e40d16101b92948cd1e13c7bc1f3062;hp=71a17b3ca0ca14ae5567f3598ad05c5c8823d353;hpb=b24f59e79a89a6cac0fa49a68355296ecb98d7ea;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 71a17b3..88b0ba9 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -28,21 +28,22 @@ import DsMonad import qualified Language.Haskell.TH as TH import HsSyn +import Class (FunDep) import PrelNames ( rationalTyConName, integerTyConName, negateName ) -import OccName ( isDataOcc, isTvOcc, occNameUserString ) +import OccName ( isDataOcc, isTvOcc, occNameString ) -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName -- we do this by removing varName from the import of OccName above, making -- a qualified instance of OccName and using OccNameAlias.varName where varName -- ws previously used in this file. import qualified OccName -import Module ( Module, mkModule, mkModuleName, moduleUserString ) +import Module ( Module, mkModule, moduleString ) import Id ( Id, mkLocalId ) -import OccName ( mkOccFS ) +import OccName ( mkOccNameFS ) import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, isExternalName, getSrcLoc ) import NameEnv -import Type ( Type, mkGenTyConApp ) +import Type ( Type, mkTyConApp ) import TcType ( tcTyConAppArgs ) import TyCon ( tyConName ) import TysWiredIn ( parrTyCon ) @@ -52,12 +53,10 @@ 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 Bag ( bagToList, unionManyBags ) import FastString ( unpackFS ) -import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..), - CCallTarget(..) ) +import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) import Monad ( zipWithM ) import List ( sortBy ) @@ -112,12 +111,12 @@ repTopDs group decls <- addBinds ss (do { - val_ds <- mapM rep_bind_group (hs_valds group) ; + val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (hs_tyclds group) ; inst_ds <- mapM repInstD' (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -132,7 +131,7 @@ repTopDs group groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group - = collectGroupBinders val_decls ++ + = collectHsValBinders val_decls ++ [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ [n | L _ (ForeignImport n _ _ _) <- foreign_decls] @@ -198,23 +197,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 ds_msg 4 (ppr d)) ; - return Nothing - } +repTyClD (L loc d) = putSrcSpanDs loc $ + do { dsWarn (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 -> @@ -272,22 +285,21 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L loc (ConDecl con [] (L _ []) details)) +repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98)) = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repC (L loc (ConDecl con tvs (L cloc ctxt) details)) +repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98)) = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con [] (L cloc []) details)); + c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98)); 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)) +repC (L loc con_decl) -- GADTs + = putSrcSpanDs loc $ + do { dsWarn (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 ty= do @@ -331,8 +343,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc -rep_sig other = return [] +rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig other = return [] rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; @@ -498,13 +510,17 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; z <- repLetE ds e2 ; wrapGenSyns ss z } -- FIXME: I haven't got the types here right yet -repE (HsDo DoExpr sts _ ty) +repE (HsDo DoExpr sts body ty) = do { (ss,zs) <- repLSts sts; - e <- repDoE (nonEmptyCoreList zs); + body' <- addBinds ss $ repLE body; + ret <- repNoBindSt body'; + e <- repDoE (nonEmptyCoreList (zs ++ [ret])); wrapGenSyns ss e } -repE (HsDo ListComp sts _ ty) +repE (HsDo ListComp sts body ty) = do { (ss,zs) <- repLSts sts; - e <- repComp (nonEmptyCoreList zs); + body' <- addBinds ss $ repLE body; + ret <- repNoBindSt body'; + e <- repComp (nonEmptyCoreList (zs ++ [ret])); wrapGenSyns ss e } repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } @@ -513,17 +529,17 @@ repE (ExplicitPArr ty es) = repE (ExplicitTuple es boxed) | isBoxed boxed = do { xs <- repLEs es; repTup xs } | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples" -repE (RecordCon c flds) +repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd e flds) +repE (RecordUpd e flds _ _) = do { x <- repLE e; fs <- repFields flds; repRecUpd x fs } repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } -repE (ArithSeqIn aseq) = +repE (ArithSeq _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do @@ -539,7 +555,7 @@ repE (ArithSeqIn aseq) = ds2 <- repLE e2 ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" +repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets" @@ -578,7 +594,7 @@ repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) = ; wrapGenSyns (ss1++ss2) clause }}} repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) -repGuards [L _ (GRHS [L _ (ResultStmt e)])] +repGuards [L _ (GRHS [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM process other; @@ -587,14 +603,13 @@ repGuards other 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)])) + process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2)) = do { x <- repLNormalGE e1 e2; return ([], x) } - process (L _ (GRHS ss)) + process (L _ (GRHS ss rhs)) = do (gs, ss') <- repLSts ss - g <- repPatGE (nonEmptyCoreList ss') + rhs' <- addBinds gs $ repLE rhs + g <- repPatGE (nonEmptyCoreList ss') rhs' return (gs, g) repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp]) @@ -634,11 +649,7 @@ repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts [ResultStmt e] = - do { a <- repLE e - ; e1 <- repNoBindSt a - ; return ([], [e1]) } -repSts (BindStmt p e : ss) = +repSts (BindStmt p e _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -651,12 +662,12 @@ repSts (LetStmt bs : ss) = ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e ty : ss) = +repSts (ExprStmt e _ _ : ss) = do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts [] = panic "repSts ran out of statements" +repSts [] = return ([],[]) repSts other = panic "Exotic Stmt in meta brackets" @@ -664,38 +675,39 @@ repSts other = panic "Exotic Stmt in meta brackets" -- Bindings ----------------------------------------------------------- -repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds decs - = do { let { bndrs = map unLoc (collectGroupBinders decs) } +repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds EmptyLocalBinds + = do { core_list <- coreList decQTyConName [] + ; return ([], core_list) } + +repBinds (HsIPBinds _) + = panic "DsMeta:repBinds: can't do implicit parameters" + +repBinds (HsValBinds decs) + = do { let { bndrs = map unLoc (collectHsValBinders decs) } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group ; ss <- mkGenSyms bndrs - ; core <- addBinds ss (rep_bind_groups decs) - ; core_list <- coreList decQTyConName core + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreList decQTyConName + (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ] --- Assumes: all the binders of the binding are alrady in the meta-env -rep_bind_groups binds = do - locs_cores_s <- mapM rep_bind_group binds - return $ de_loc $ sort_by_loc (concat locs_cores_s) - -rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are alrady in the meta-env -rep_bind_group (HsBindGroup bs sigs _) - = do { core1 <- mapM rep_bind (bagToList bs) +rep_val_binds (ValBindsOut binds sigs) + = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_bind_group (HsIPBinds _) - = panic "DsMeta:repBinds: can't do implicit parameters" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] --- Assumes: all the binders of the binding are alrady in the meta-env -rep_binds binds = do - locs_cores <- mapM rep_bind (bagToList binds) - return $ de_loc $ sort_by_loc locs_cores +rep_binds binds = do { binds_w_locs <- rep_binds' binds + ; return (de_loc (sort_by_loc binds_w_locs)) } + +rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' binds = mapM rep_bind (bagToList binds) rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env @@ -703,7 +715,8 @@ 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 (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _))) +rep_bind (L loc (FunBind { fun_id = fn, + fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -712,13 +725,13 @@ rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards whe ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind fn infx (MatchGroup ms _))) +rep_bind (L loc (FunBind { fun_id = fn, fun_matches = 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_lhs = pat, pat_rhs = GRHSs guards wheres })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -726,7 +739,7 @@ rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2)) ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (VarBind v e)) +rep_bind (L loc (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2 @@ -760,7 +773,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 [] e)] EmptyLocalBinds))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -786,14 +799,14 @@ repLP :: LPat Name -> DsM (Core TH.PatQ) repLP (L _ p) = repP p 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' } -repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } -repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } -repP (ParPat p) = repLP p -repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } -repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs } +repP (WildPat _) = repPwild +repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } +repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } +repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (ParPat p) = repLP p +repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } +repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -807,8 +820,8 @@ repP (ConPatIn dc details) 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 (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))" +repP (NPat 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" @@ -863,11 +876,11 @@ lookupBinder n = do { mb_val <- dsLookupMetaEnv n; case mb_val of Just (Bound x) -> return (coreVar x) - other -> pprPanic "Failed binder lookup:" (ppr n) } + other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) } -- Look up a name that is either locally bound or a global name -- --- * If it is a global name, generate the "original name" representation (ie, +-- * If it is a global name, generate the "original name" representation (ie, -- the : form) for the associated entity -- lookupLOcc :: Located Name -> DsM (Core TH.Name) @@ -897,9 +910,9 @@ 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_mod = moduleString (nameModule name) name_occ = nameOccName name mk_varg | OccName.isDataOcc name_occ = mkNameG_dName | OccName.isVarOcc name_occ = mkNameG_vName @@ -909,7 +922,7 @@ globalVar name lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) -> DsM Type -- The type lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; - return (mkGenTyConApp tc []) } + return (mkTyConApp tc []) } wrapGenSyns :: [GenSymBind] -> Core (TH.Q a) -> DsM (Core (TH.Q a)) @@ -951,7 +964,7 @@ wrapNongenSyms binds (MkC body) ; return (NonRec id var) } occNameLit :: Name -> DsM (Core String) -occNameLit n = coreStringLit (occNameUserString (nameOccName n)) +occNameLit n = coreStringLit (occNameString (nameOccName n)) -- %********************************************************************* @@ -1093,8 +1106,8 @@ repLNormalGE g e = do g' <- repLE g 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] +repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) +repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] ------------- Stmts ------------------- repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ) @@ -1147,8 +1160,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] @@ -1238,7 +1254,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName mk_rational r = do rat_ty <- lookupType rationalTyConName return $ HsRat r rat_ty -repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit) +repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit } repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit } -- The type Rational will be in the environment, becuase @@ -1309,7 +1325,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, @@ -1359,6 +1375,8 @@ templateHaskellNames = [ unsafeName, safeName, threadsafeName, + -- FunDep + funDepName, -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, @@ -1366,18 +1384,14 @@ 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) + = mkExternalName uniq mod (mkOccNameFS space str) Nothing noSrcLoc libFun = mk_known_key_name thLib OccName.varName @@ -1386,16 +1400,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 @@ -1406,7 +1421,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 ----------------------- @@ -1533,6 +1548,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 +1589,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 @@ -1584,7 +1603,7 @@ mkNameIdKey = mkPreludeMiscIdUnique 205 mkNameG_vIdKey = mkPreludeMiscIdUnique 206 mkNameG_dIdKey = mkPreludeMiscIdUnique 207 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 -mkNameUIdKey = mkPreludeMiscIdUnique 209 +mkNameLIdKey = mkPreludeMiscIdUnique 209 -- data Lit = ... @@ -1708,3 +1727,6 @@ unsafeIdKey = mkPreludeMiscIdUnique 305 safeIdKey = mkPreludeMiscIdUnique 306 threadsafeIdKey = mkPreludeMiscIdUnique 307 +-- data FunDep = ... +funDepIdKey = mkPreludeMiscIdUnique 320 +