X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=2e813146f1ffb3499df374a47690a00dc20f7668;hb=2a130b134daa3d67fed0b5b2e2257446e2c23c76;hp=0744dae1e18d4eb2859c7bd2d1be0cb483836665;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 0744dae..2e81314 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -44,6 +44,7 @@ import TcMType import TcHsType import TcIface import TypeRep +import InstEnv import Name import NameEnv import NameSet @@ -342,16 +343,17 @@ tcBracket brack res_ty ; lie_var <- getConstraintVar ; let brack_stage = Brack cur_stage pending_splices lie_var - ; (meta_ty, lie) <- setStage brack_stage $ - getConstraints $ - tc_bracket cur_stage brack - - ; simplifyBracket lie - - -- Make the expected type have the right shape - ; _ <- unifyType meta_ty res_ty - - -- Return the original expression, not the type-decorated one + -- We want to check that there aren't any constraints that + -- can't be satisfied (e.g. Show Foo, where Foo has no Show + -- instance), but we aren't otherwise interested in the + -- results. Nor do we care about ambiguous dictionaries etc. + -- We will type check this bracket again at its usage site. + ; _ <- newImplication BracketSkol [] [] $ + setStage brack_stage $ + do { meta_ty <- tc_bracket cur_stage brack + ; unifyType meta_ty res_ty } + + -- Return the original expression, not the type-decorated one ; pendings <- readMutVar pending_splices ; return (noLoc (HsBracketOut brack pendings)) } @@ -394,7 +396,7 @@ tc_bracket _ (DecBrG decls) tc_bracket _ (PatBr pat) = do { any_ty <- newFlexiTyVarTy liftedTypeKind - ; _ <- tcPat ThPatQuote pat any_ty unitTy $ + ; _ <- tcPat ThPatQuote pat any_ty $ return () ; tcMetaTy patQTyConName } -- Result type is PatQ (= Q Pat) @@ -486,7 +488,7 @@ tcTopSpliceExpr tc_action -- if the type checker fails! setStage Splice $ do { -- Typecheck the expression - (expr', lie) <- getConstraints tc_action + (expr', lie) <- captureConstraints tc_action -- Solve the constraints ; const_binds <- simplifyTop lie @@ -663,7 +665,17 @@ runQuasiQuote :: Outputable hs_syn -> MetaOps th_syn hs_syn -> RnM hs_syn runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops - = do { quoter' <- lookupOccRn quoter + = do { -- Drop the leading "$" from the quoter name, if present + -- This is old-style syntax, now deprecated + -- NB: when removing this backward-compat, remove + -- the matching code in Lexer.x (around line 310) + let occ_str = occNameString (rdrNameOcc quoter) + ; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this + if head occ_str /= '$' then return quoter + else do { addWarn (deprecatedDollar quoter) + ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) } + + ; quoter' <- lookupOccRn quoter -- We use lookupOcc rather than lookupGlobalOcc because in the -- erroneous case of \x -> [x| ...|] we get a better error message -- (stage restriction rather than out of scope). @@ -708,6 +720,12 @@ 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"))] + +deprecatedDollar :: RdrName -> SDoc +deprecatedDollar quoter + = hang (ptext (sLit "Deprecated syntax:")) + 2 (ptext (sLit "quasiquotes no longer need a dollar sign:") + <+> ppr quoter) \end{code} @@ -786,7 +804,7 @@ runMeta show_code run_and_convert expr ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM ; either_hval <- tryM $ liftIO $ - HscMain.compileExpr hsc_env src_span ds_expr + HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do @@ -874,6 +892,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } qReify v = reify v + qClassInstances = lookupClassInstances -- For qRecover, discard error messages if -- the recovery action is chosen. Otherwise @@ -917,6 +936,32 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou %************************************************************************ %* * + Instance Testing +%* * +%************************************************************************ + +\begin{code} +lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.ClassInstance] +lookupClassInstances c ts + = do { loc <- getSrcSpanM + ; case convertToHsPred loc (TH.ClassP c ts) of { + Left msg -> failWithTc msg; + Right rdr_pred -> do + { rn_pred <- rnLPred doc rdr_pred -- Rename + ; kc_pred <- kcHsLPred rn_pred -- Kind check + ; ClassP cls tys <- dsHsLPred kc_pred -- Type check + + -- Now look up instances + ; inst_envs <- tcGetInstEnvs + ; let (matches, unifies) = lookupInstEnv inst_envs cls tys + ; mapM reifyClassInstance (map fst matches ++ unifies) } } } + where + doc = ptext (sLit "TcSplice.classInstances") +\end{code} + + +%************************************************************************ +%* * Reification %* * %************************************************************************ @@ -1103,8 +1148,11 @@ reifyDataCon tys dc reifyClass :: Class -> TcM TH.Info reifyClass cls = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls) ; ops <- mapM reify_op op_stuff - ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } + ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops + ; return (TH.ClassI dec insts ) } where (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds @@ -1112,7 +1160,22 @@ reifyClass cls ; return (TH.SigD (reifyName op) ty) } ------------------------------ +reifyClassInstance :: Instance -> TcM TH.ClassInstance +reifyClassInstance i + = do { cxt <- reifyCxt theta + ; thtypes <- reifyTypes types + ; return $ (TH.ClassInstance { + TH.ci_tvs = reifyTyVars tvs, + TH.ci_cxt = cxt, + TH.ci_tys = thtypes, + TH.ci_cls = reifyName cls, + TH.ci_dfun = reifyName (is_dfun i) }) } + where + (tvs, theta, cls, types) = instanceHead i + +------------------------------ reifyType :: TypeRep.Type -> TcM TH.Type +-- Monadic only because of failure reifyType ty@(ForAllTy _ _) = reify_for_all ty reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))