X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=5a5bb1b1a9d8b0271ae3bdff53c0f38a7a5886f1;hp=77e9e082243518701ea98018676ceb1dd0a55127;hb=92eeda1e1d846a082a60caab1b75593d7cc668ed;hpb=7f546581e86c816ece1f7c877560ffa1cf385165 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 77e9e08..5a5bb1b 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -1,44 +1,46 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % This module converts Template Haskell syntax into HsSyn - \begin{code} -module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details -#include "HsVersions.h" - -import Language.Haskell.TH as TH hiding (sigP) -import Language.Haskell.TH.Syntax as TH +module Convert( convertToHsExpr, convertToPat, convertToHsDecls, + convertToHsType, thRdrName ) where import HsSyn as Hs -import qualified Class (FunDep) -import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName ) -import qualified Name ( Name, mkInternalName, getName ) -import Module ( Module, mkModule ) -import RdrHsSyn ( mkClassDecl, mkTyData ) +import qualified Class +import RdrName +import qualified Name +import Module +import RdrHsSyn import qualified OccName -import OccName ( startsVarId, startsVarSym, startsConId, startsConSym, - pprNameSpace ) -import SrcLoc ( Located(..), SrcSpan ) -import Type ( Type ) -import TysWiredIn ( unitTyCon, tupleTyCon, tupleCon, trueDataCon, nilDataCon, consDataCon ) -import BasicTypes( Boxity(..) ) -import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), - CExportSpec(..)) -import Char ( isAscii, isAlphaNum, isAlpha ) -import List ( partition ) -import Unique ( Unique, mkUniqueGrimily ) -import ErrUtils ( Message ) -import GLAEXTS ( Int(..), Int# ) -import SrcLoc ( noSrcLoc ) -import Bag ( listToBag ) +import OccName +import SrcLoc +import Type +import TysWiredIn +import BasicTypes +import ForeignCall +import Char +import List +import Unique +import ErrUtils +import Bag import FastString import Outputable +import Language.Haskell.TH as TH hiding (sigP) +import Language.Haskell.TH.Syntax as TH +import GHC.Exts ------------------------------------------------------------------- -- The external interface @@ -49,10 +51,17 @@ convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds) convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName) convertToHsExpr loc e = case initCvt loc (cvtl e) of - Left msg -> Left (msg $$ (ptext SLIT("When converting TH expression") + Left msg -> Left (msg $$ (ptext (sLit "When converting TH expression") <+> text (show e))) Right res -> Right res +convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName) +convertToPat loc e + = case initCvt loc (cvtPat e) of + Left msg -> Left (msg $$ (ptext (sLit "When converting TH pattern") + <+> text (show e))) + Right res -> Right res + convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) convertToHsType loc t = initCvt loc (cvtType t) @@ -72,7 +81,7 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } -- the spliced-in declarations get a location that at least relates to the splice point instance Monad CvtM where - return x = CvtM $ \loc -> Right x + return x = CvtM $ \_ -> Right x (CvtM m) >>= k = CvtM $ \loc -> case m loc of Left err -> Left err Right v -> unCvtM (k v) loc @@ -84,9 +93,9 @@ force :: a -> CvtM a force a = a `seq` return a failWith :: Message -> CvtM a -failWith m = CvtM (\loc -> Left full_msg) +failWith m = CvtM (\_ -> Left full_msg) where - full_msg = m $$ ptext SLIT("When splicing generated code into the program") + full_msg = m $$ ptext (sLit "When splicing generated code into the program") returnL :: a -> CvtM (Located a) returnL x = CvtM (\loc -> Right (L loc x)) @@ -108,7 +117,7 @@ cvtTop (TySynD tc tvs rhs) = do { tc' <- tconNameL tc ; tvs' <- cvtTvs tvs ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' rhs') } + ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } cvtTop (DataD ctxt tc tvs constrs derivs) = do { stuff <- cvt_tycl_hdr ctxt tc tvs @@ -124,49 +133,60 @@ cvtTop (NewtypeD ctxt tc tvs constr derivs) ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') } cvtTop (ClassD ctxt cl tvs fds decs) - = do { stuff <- cvt_tycl_hdr ctxt cl tvs + = do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds ; (binds', sigs') <- cvtBindsAndSigs decs - ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' } + ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] [] + -- no ATs or docs in TH ^^ ^^ + } cvtTop (InstanceD tys ty decs) = do { (binds', sigs') <- cvtBindsAndSigs decs ; ctxt' <- cvtContext tys ; L loc pred' <- cvtPred ty ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) - ; returnL $ InstD (InstDecl inst_ty' binds' sigs') } + ; returnL $ InstD (InstDecl inst_ty' binds' sigs' []) + -- no ATs in TH ^^ + } cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' } +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name] + -> CvtM (LHsContext RdrName + ,Located RdrName + ,[LHsTyVarBndr RdrName] + ,Maybe [LHsType RdrName]) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') } + ; return (cxt', tc', tvs', Nothing) } --------------------------------------------------- -- Data types -- Can't handle GADTs yet --------------------------------------------------- +cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) + cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 } + ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing } cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con')) = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con') @@ -176,17 +196,21 @@ cvtConstr (ForallC tvs ctxt con) ; tvs' <- cvtTvs tvs ; ctxt' <- cvtContext ctxt ; case con' of - ConDecl l _ [] (L _ []) x ResTyH98 - -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 - c -> panic "ForallC: Can't happen" } + ConDecl l _ [] (L _ []) x ResTyH98 _ + -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing + _ -> panic "ForallC: Can't happen" } +cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } cvt_arg (NotStrict, ty) = cvtType ty -cvt_id_arg (i, str, ty) = do { i' <- vNameL i - ; ty' <- cvt_arg (str,ty) - ; return (i', ty') } +cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) +cvt_id_arg (i, str, ty) + = do { i' <- vNameL i + ; ty' <- cvt_arg (str,ty) + ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) } +cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName]) cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just cs') } @@ -197,6 +221,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName)) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') } +noExistentials :: [LHsTyVarBndr RdrName] noExistentials = [] ------------------------------------------ @@ -209,10 +234,10 @@ cvtForD (ImportF callconv safety from nm ty) = do { nm' <- vNameL nm ; ty' <- cvtType ty ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis - ; return $ ForeignImport nm' ty' i False } + ; return $ ForeignImport nm' ty' i } | otherwise - = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent") + = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent") where safety' = case safety of Unsafe -> PlayRisky @@ -223,10 +248,11 @@ cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameL nm ; ty' <- cvtType ty ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv)) - ; return $ ForeignExport nm' ty' e False } + ; return $ ForeignExport nm' ty' e } -cvt_conv CCall = CCallConv -cvt_conv StdCall = StdCallConv +cvt_conv :: TH.Callconv -> CCallConv +cvt_conv TH.CCall = CCallConv +cvt_conv TH.StdCall = StdCallConv parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec) parse_ccall_impent nm s @@ -278,6 +304,7 @@ cvtDecs [] = return EmptyLocalBinds cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds ; return (HsValBinds (ValBindsIn binds sigs)) } +cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName]) cvtBindsAndSigs ds = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs ; return (listToBag binds', sigs') } @@ -285,8 +312,9 @@ cvtBindsAndSigs ds (sigs, binds) = partition is_sig ds is_sig (TH.SigD _ _) = True - is_sig other = False + is_sig _ = False +cvtSig :: TH.Dec -> CvtM (LSig RdrName) cvtSig (TH.SigD nm ty) = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') } @@ -311,7 +339,7 @@ cvtBind (TH.ValD p body ds) pat_rhs_ty = void, bind_fvs = placeHolderNames } } cvtBind d - = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"), + = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"), nest 2 (text (TH.pprint d))]) cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName) @@ -338,7 +366,7 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } - cvt (TupE [e]) = cvt e + cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z ; return $ HsIf x' y' z' } @@ -362,12 +390,15 @@ cvtl e = wrapL (cvt e) ; return $ ExprWithTySig e' t' } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM cvtFld flds - ; return $ RecordCon c' noPostTcExpr flds' } + ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)} cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' <- mapM cvtFld flds - ; return $ RecordUpd e' flds' placeHolderType placeHolderType } + ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } -cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') } +cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) +cvtFld (v,e) + = do { v' <- vNameL v; e' <- cvtl e + ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) } cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -379,12 +410,14 @@ cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; retur -- Do notation and statements ------------------------------------- +cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName) cvtHsDo do_or_lc stmts = do { stmts' <- cvtStmts stmts ; let body = case last stmts' of L _ (ExprStmt body _ _) -> body ; return $ HsDo do_or_lc (init stmts') body void } +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName] cvtStmts = mapM cvtStmt cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName) @@ -408,19 +441,21 @@ cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; retur cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs - ; g' <- returnL $ mkBindStmt truePat ge' + ; g' <- returnL $ mkExprStmt ge' ; returnL $ GRHS [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) -cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i } -cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r } +cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType} +cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType} +cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType } -- An Integer is like an an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals cvtLit :: Lit -> CvtM HsLit cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } cvtLit (CharL c) = do { force c; return $ HsChar c } @@ -449,11 +484,14 @@ cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon fs' } + ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } -cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') } +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) +cvtPatFld (s,p) + = do { s' <- vNameL s; p' <- cvtPat p + ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } ----------------------------------------------------------- -- Types and type variables @@ -461,6 +499,7 @@ cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') } cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName] cvtTvs tvs = mapM cvt_tv tvs +cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName) cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' } cvtContext :: Cxt -> CvtM (LHsContext RdrName) @@ -472,13 +511,16 @@ cvtPred ty ; case head of ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' } VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' } - other -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) } + _ -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) } cvtType :: TH.Type -> CvtM (LHsType RdrName) -cvtType ty = do { (head, tys') <- split_ty_app ty - ; case head of - TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys') - | n == 0 -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys' +cvtType ty = do { (head_ty, tys') <- split_ty_app ty + ; case head_ty of + TupleT n | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy Boxed tys') + | n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') ListT | [x'] <- tys' -> returnL (HsListTy x') @@ -489,11 +531,12 @@ cvtType ty = do { (head, tys') <- split_ty_app ty ; cxt' <- cvtContext cxt ; ty' <- cvtType ty ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' } - otherwise -> failWith (ptext SLIT("Malformed type") <+> text (show ty)) + _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) } where - mk_apps head [] = returnL head - mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys } + mk_apps head_ty [] = returnL head_ty + mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty + ; mk_apps (HsAppTy head_ty' ty) tys } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) split_ty_app ty = go ty [] @@ -507,13 +550,11 @@ split_ty_app ty = go ty [] ----------------------------------------------------------- -- some useful things -truePat = nlConPat (getRdrName trueDataCon) [] - overloadedLit :: Lit -> Bool -- True for literals that Haskell treats as overloaded -overloadedLit (IntegerL l) = True -overloadedLit (RationalL l) = True -overloadedLit l = False +overloadedLit (IntegerL _) = True +overloadedLit (RationalL _) = True +overloadedLit _ = False void :: Type.Type void = placeHolderType @@ -555,8 +596,8 @@ okOcc ns str@(c:_) badOcc :: OccName.NameSpace -> String -> SDoc badOcc ctxt_ns occ - = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns - <+> ptext SLIT("name:") <+> quotes (text occ) + = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns + <+> ptext (sLit "name:") <+> quotes (text occ) thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- This turns a Name into a RdrName @@ -569,8 +610,8 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName ctxt_ns occ (TH.NameG th_ns mod) = (mkOrig $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ) -thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc) +thRdrName _ occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) +thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) thRdrName ctxt_ns occ TH.NameS @@ -586,11 +627,11 @@ isBuiltInOcc ctxt_ns occ "[]" -> Just (Name.getName nilDataCon) "()" -> Just (tup_name 0) '(' : ',' : rest -> go_tuple 2 rest - other -> Nothing + _ -> Nothing where go_tuple n ")" = Just (tup_name n) go_tuple n (',' : rest) = go_tuple (n+1) rest - go_tuple n other = Nothing + go_tuple _ _ = Nothing tup_name n | OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n) @@ -617,8 +658,11 @@ mk_ghc_ns TH.DataName = OccName.dataName mk_ghc_ns TH.TcClsName = OccName.tcClsName mk_ghc_ns TH.VarName = OccName.varName -mk_mod :: TH.ModName -> Module -mk_mod mod = mkModule (TH.modString mod) +mk_mod :: TH.ModName -> ModuleName +mk_mod mod = mkModuleName (TH.modString mod) + +mk_pkg :: TH.ModName -> PackageId +mk_pkg pkg = stringToPackageId (TH.pkgString pkg) mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u)