X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=6da5741037196fb8207de34c47ce44994914899a;hp=b96307d215521d7360e090d3066aabf7338fc6dd;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=debb7b80e707c343a3a7d8993ffab19b83e5c52b diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index b96307d..6da5741 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -71,6 +71,7 @@ import SrcLoc import Outputable import Util ( dropList ) import Data.List ( mapAccumL ) +import Pair import Unique import Data.Maybe import BasicTypes @@ -343,16 +344,29 @@ tcBracket brack res_ty ; lie_var <- getConstraintVar ; let brack_stage = Brack cur_stage pending_splices lie_var - ; (meta_ty, lie) <- setStage brack_stage $ - captureConstraints $ - 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)) } @@ -373,7 +387,7 @@ tc_bracket outer_stage (VarBr name) -- Note [Quoting names] } 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) @@ -394,8 +408,8 @@ tc_bracket _ (DecBrG decls) ; 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) @@ -664,7 +678,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). @@ -709,6 +733,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} @@ -787,7 +817,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 @@ -867,13 +897,17 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qReport False msg = addReport (text msg) empty qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = packageIdString (modulePackageId m) - , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l) - , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } - + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + qReify v = reify v qClassInstances = lookupClassInstances @@ -924,11 +958,11 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou %************************************************************************ \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 @@ -937,8 +971,7 @@ lookupClassInstances c ts -- 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} @@ -1038,8 +1071,9 @@ reifyThing (AGlobal (AnId id)) _ -> return (TH.VarI v ty Nothing fix) } -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AClass cls)) = reifyClass cls +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax +reifyThing (AGlobal (AClass cls)) = reifyClass cls reifyThing (AGlobal (ADataCon dc)) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) @@ -1063,12 +1097,24 @@ reifyThing (ATyVar tv ty) reifyThing (AThing {}) = panic "reifyThing AThing" ------------------------------ +reifyAxiom :: CoAxiom -> TcM TH.Info +reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs }) + | Just (tc, args) <- tcSplitTyConApp_maybe lhs + = do { args' <- mapM reifyType args + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') } + | otherwise + = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax + <+> dcolon <+> pprEqPred (Pair lhs rhs)) + reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) + | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) + | isFamilyTyCon tc = let flavour = reifyFamFlavour tc tvs = tyConTyVars tc @@ -1079,6 +1125,7 @@ reifyTyCon tc in return (TH.TyConI $ TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind') + | isSynTyCon tc = do { let (tvs, rhs) = synTyConDefn tc ; rhs' <- reifyType rhs @@ -1086,7 +1133,7 @@ reifyTyCon tc TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } -reifyTyCon tc + | otherwise = do { cxt <- reifyCxt (tyConStupidTheta tc) ; let tvs = tyConTyVars tc ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) @@ -1161,7 +1208,7 @@ reifyClassInstance 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 ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }