X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=7139fa8da844b7a9b3ebef0816944ee4d80f192c;hp=48cec19292f4e9f0eb7d6224bc5d85dcb3de30b2;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=80ef1f06253f1a20a63816c295e180e47cd9a347 diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 48cec19..7139fa8 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -6,7 +6,7 @@ TcSplice: Template Haskell splices \begin{code} -{-# OPTIONS -w #-} +{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-} -- 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 @@ -46,7 +46,6 @@ import OccName import Var import Module import TcRnMonad -import IfaceEnv import Class import TyCon import DataCon @@ -60,20 +59,23 @@ import ErrUtils import SrcLoc import Outputable import Unique -import DynFlags -import PackageConfig import Maybe import BasicTypes import Panic import FastString +import Data.Typeable (cast) +import Exception import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) -import Control.Monad ( liftM ) -import qualified Control.Exception as Exception( userErrors ) +#if __GLASGOW_HASKELL__ < 609 +import qualified Exception ( userErrors ) +#else +import System.IO.Error +#endif \end{code} Note [Template Haskell levels] @@ -161,6 +163,7 @@ The predicate we use is TcEnv.thTopLevelId. %************************************************************************ \begin{code} +tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) @@ -170,11 +173,13 @@ runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName) runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) #ifndef GHCI -tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) -tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) +tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) +tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) +tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) +kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) -runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) -runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) +runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) +runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) #else \end{code} @@ -197,7 +202,6 @@ Desugared: f = do { s7 <- g Int 3 ; return (ConE "Data.Maybe.Just" s7) } \begin{code} -tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcBracket brack res_ty = do level <- getStage case bracketOK level of { @@ -234,23 +238,23 @@ tc_bracket use_lvl (VarBr name) -- Note [Quoting names] | otherwise -> do { checkTc (use_lvl == bind_lvl) (quotedNameStageErr name) } - other -> pprPanic "th_bracket" (ppr name) + _ -> pprPanic "th_bracket" (ppr name) ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) } -tc_bracket use_lvl (ExpBr expr) +tc_bracket _ (ExpBr expr) = do { any_ty <- newFlexiTyVarTy liftedTypeKind ; tcMonoExpr expr any_ty ; tcMetaTy expQTyConName } -- Result type is Expr (= Q Exp) -tc_bracket use_lvl (TypBr typ) +tc_bracket _ (TypBr typ) = do { tcHsSigType ExprSigCtxt typ ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) -tc_bracket use_lvl (DecBr decls) +tc_bracket _ (DecBr decls) = do { tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -261,12 +265,13 @@ tc_bracket use_lvl (DecBr decls) -- Result type is Q [Dec] } -tc_bracket use_lvl (PatBr _) - = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")) +tc_bracket _ (PatBr _) + = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet")) +quotedNameStageErr :: Name -> SDoc quotedNameStageErr v - = sep [ ptext SLIT("Stage error: the non-top-level quoted name") <+> ppr (VarBr v) - , ptext SLIT("must be used at the same stage at which is is bound")] + = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v) + , ptext (sLit "must be used at the same stage at which is is bound")] \end{code} @@ -307,6 +312,8 @@ tcSpliceExpr (HsSplice name expr) res_ty writeMutVar ps_var ((name,expr') : ps) return (panic "tcSpliceExpr") -- The returned expression is ignored + + ; Splice {} -> panic "tcSpliceExpr Splice" }} -- tcTopSplice used to have this: @@ -334,7 +341,7 @@ tcTopSplice expr res_ty = do -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - (exp3, fvs) <- checkNoErrs (rnLExpr expr2) + (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) tcMonoExpr exp3 res_ty @@ -393,7 +400,7 @@ runQuasiQuote :: Outputable hs_syn -> Name -- Name of th_syn type -> (SrcSpan -> th_syn -> Either Message hs_syn) -> TcM hs_syn -runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert +runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert = do { -- Check that the quoter is not locally defined, otherwise the TH -- machinery will not be able to run the quasiquote. ; this_mod <- getModule @@ -430,9 +437,10 @@ runQuasiQuoteExpr quasiquote runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat +quoteStageError :: Name -> SDoc quoteStageError quoter - = sep [ptext SLIT("GHC stage restriction:") <+> ppr quoter, - nest 2 (ptext SLIT("is used in a quasiquote, and must be imported, not defined locally"))] + = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter, + nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))] \end{code} @@ -472,7 +480,9 @@ kcSpliceType (HsSplice name hs_expr) -- but $(h 4) :: forall a.a i.e. any kind ; kind <- newKindVar ; return (panic "kcSpliceType", kind) -- The returned type is ignored - }}}}} + } + ; Splice {} -> panic "kcSpliceType Splice" + }}}} kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind) kcTopSpliceType expr @@ -491,7 +501,7 @@ kcTopSpliceType expr -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - ; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2 + ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) ; kcHsType hs_ty3 } @@ -522,12 +532,6 @@ tcSpliceDecls expr zonked_q_expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) ; return decls } - - where handleErrors :: [Either a Message] -> TcM [a] - handleErrors [] = return [] - handleErrors (Left x:xs) = liftM (x:) (handleErrors xs) - handleErrors (Right m:xs) = do addErrTc m - handleErrors xs \end{code} @@ -595,10 +599,24 @@ runMeta convert expr ; case either_tval of Right v -> return v +#if __GLASGOW_HASKELL__ < 609 Left exn | Just s <- Exception.userErrors exn , s == "IOEnv failure" -> failM -- Error already in Tc monad | otherwise -> failWithTc (mk_msg "run" exn) -- Exception +#else + Left (SomeException exn) -> + case cast exn of + Just (ErrorCall "IOEnv failure") -> + failM -- Error already in Tc monad + _ -> + case cast exn of + Just ioe + | isUserError ioe && + (ioeGetErrorString ioe == "IOEnv failure") -> + failM -- Error already in Tc monad + _ -> failWithTc (mk_msg "run" exn) -- Exception +#endif }}} where mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", @@ -687,11 +705,13 @@ showSplice what before after = do text "======>", nest 2 after])]) +illegalBracket :: ThStage -> SDoc illegalBracket level - = ptext SLIT("Illegal bracket at level") <+> ppr level + = ptext (sLit "Illegal bracket at level") <+> ppr level +illegalSplice :: ThStage -> SDoc illegalSplice level - = ptext SLIT("Illegal splice at level") <+> ppr level + = ptext (sLit "Illegal splice at level") <+> ppr level #endif /* GHCI */ \end{code} @@ -718,28 +738,33 @@ reify th_name ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns _ = panic "reify/ppr_ns" lookupThName :: TH.Name -> TcM Name lookupThName th_name@(TH.Name occ flavour) - = do { let rdr_name = thRdrName guessed_ns occ_str flavour - - -- Repeat much of lookupOccRn, becase we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return name - Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig - -> lookupImportedName rdr_name - | otherwise -- Unqual, Qual - -> do { mb_name <- lookupSrcOcc_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> failWithTc (notInScope th_name) } - } + = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour + | gns <- guessed_nss] + ; case catMaybes mb_ns of + [] -> failWithTc (notInScope th_name) + (n:_) -> return n } -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A + -- in preference to the data constructor A where - -- guessed_ns is the name space guessed from looking at the TH name - guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName - | otherwise = OccName.varName + lookup rdr_name + = do { -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig + -> do { name <- lookupImportedName rdr_name + ; return (Just name) } + | otherwise -- Unqual, Qual + -> lookupSrcOcc_maybe rdr_name } + + -- guessed_ns are the name spaces guessed from looking at the TH name + guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] + | otherwise = [OccName.varName, OccName.tvName] occ_str = TH.occString occ tcLookupTh :: Name -> TcM TcTyThing @@ -770,12 +795,12 @@ tcLookupTh name notInScope :: TH.Name -> SDoc notInScope th_name = quotes (text (TH.pprint th_name)) <+> - ptext SLIT("is not in scope at a reify") + ptext (sLit "is not in scope at a reify") -- Ugh! Rather an indirect way to display the name notInEnv :: Name -> SDoc notInEnv name = quotes (ppr name) <+> - ptext SLIT("is not in the type environment at a reify") + ptext (sLit "is not in the type environment at a reify") ------------------------------ reifyThing :: TcTyThing -> TcM TH.Info @@ -789,7 +814,7 @@ reifyThing (AGlobal (AnId id)) ; let v = reifyName id ; case globalIdDetails id of ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) - other -> return (TH.VarI v ty Nothing fix) + _ -> return (TH.VarI v ty Nothing fix) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -812,6 +837,8 @@ reifyThing (ATyVar tv ty) ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } +reifyThing (AThing {}) = panic "reifyThing AThing" + ------------------------------ reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc @@ -853,7 +880,7 @@ reifyDataCon tys dc else return (TH.NormalC name (stricts `zip` arg_tys)) } | otherwise - = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") + = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:") <+> quotes (ppr dc)) ------------------------------ @@ -872,7 +899,6 @@ reifyClass cls reifyType :: TypeRep.Type -> TcM TH.Type reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -reifyType (NoteTy _ ty) = reifyType ty reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; @@ -880,7 +906,11 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') } where (tvs, cxt, tau) = tcSplitSigmaTy ty +reifyType (PredTy {}) = panic "reifyType PredTy" + +reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType +reifyCxt :: [PredType] -> TcM [TH.Type] reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep @@ -895,7 +925,8 @@ reify_tc_app tc tys = do { tys' <- reifyTypes tys reifyPred :: TypeRep.PredType -> TcM TH.Type reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys -reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) +reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p) +reifyPred (EqPred {}) = panic "reifyPred EqPred" ------------------------------ @@ -909,7 +940,7 @@ reifyName thing -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = nameModule name + mod = ASSERT( isExternalName name ) nameModule name pkg_str = packageIdString (modulePackageId mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ @@ -937,7 +968,7 @@ reifyStrict NotMarkedStrict = TH.NotStrict ------------------------------ noTH :: LitString -> SDoc -> TcM a -noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+> - ptext SLIT("in Template Haskell:"), +noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> + ptext (sLit "in Template Haskell:"), nest 2 d]) \end{code}