import Outputable
import Util ( dropList )
import Data.List ( mapAccumL )
+import Pair
import Unique
import Data.Maybe
import BasicTypes
; 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)) }
}
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)
-> 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
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
%************************************************************************
\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}
_ -> 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))
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
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
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)
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) }
projects / ghc-hetmet.git / blobdiff