; 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.
+ --
+ -- We build a single implication constraint with a BracketSkol;
+ -- that in turn tells simplifyCheck to report only definite
+ -- errors
+ ; (_,lie) <- captureConstraints $
+ newImplication BracketSkol [] [] $
+ setStage brack_stage $
+ do { meta_ty <- tc_bracket cur_stage brack
+ ; unifyType meta_ty res_ty }
+
+ -- It's best to simplify the constraint now, even though in
+ -- principle some later unification might be useful for it,
+ -- because we don't want these essentially-junk TH implication
+ -- contraints floating around nested inside other constraints
+ -- See for example Trac #4949
+ ; _ <- simplifyTop lie
+
+ -- Return the original expression, not the type-decorated one
; pendings <- readMutVar pending_splices
; return (noLoc (HsBracketOut brack pendings)) }
}
tc_bracket _ (ExpBr expr)
- = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
-- Result type is ExpQ (= Q Exp)
; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
tc_bracket _ (PatBr pat)
- = do { any_ty <- newFlexiTyVarTy liftedTypeKind
- ; _ <- tcPat ThPatQuote pat any_ty unitTy $
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
+ ; _ <- tcPat ThPatQuote pat any_ty $
return ()
; tcMetaTy patQTyConName }
-- Result type is PatQ (= Q Pat)
-- 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
-> 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).
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}
; 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
%************************************************************************
\begin{code}
-lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name]
+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
+ ; 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
-- Now look up instances
; inst_envs <- tcGetInstEnvs
; let (matches, unifies) = lookupInstEnv inst_envs cls tys
- dfuns = map is_dfun (map fst matches ++ unifies)
- ; return (map reifyName dfuns) } }
+ ; mapM reifyClassInstance (map fst matches ++ unifies) } } }
where
doc = ptext (sLit "TcSplice.classInstances")
\end{code}