import Name
import TyCon
import Type
+import TypeRep
import Coercion
import Var
import VarSet
tcPolyExprNC expr res_ty
= do { traceTc "tcPolyExprNC" (ppr res_ty)
- ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho ->
+ ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
tcMonoExprNC expr rho
; return (mkLHsWrap gen_fn expr') }
%************************************************************************
\begin{code}
+
+updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a
+updHetMetLevel f comp =
+ updEnv
+ (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x)
+ in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } }))
+
+ comp
+
+addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name
+addEscapes [] e = e
+addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e))
+
+getIdLevel :: Name -> TcM [TyVar]
+getIdLevel name
+ = do { thing <- tcLookup name
+ ; case thing of
+ ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel
+ _ -> return []
+ }
+
tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
= pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
tcExpr (HsVar name) res_ty = tcCheckId name res_ty
+tcExpr (HsHetMetBrak _ e) res_ty =
+ do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty
+ ; fresh_ec_name <- newFlexiTyVar liftedTypeKind
+ ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
+ $ tcPolyExpr e elt_ty
+ ; unifyType (TyVarTy fresh_ec_name) inferred_name
+ ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }
+tcExpr (HsHetMetEsc _ _ e) res_ty =
+ do { cur_level <- getHetMetLevel
+ ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
+ $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
+ ; ty' <- zonkTcType res_ty
+ ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) }
+tcExpr (HsHetMetCSP _ e) res_ty =
+ do { cur_level <- getHetMetLevel
+ ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
+ $ tcExpr (unLoc e) res_ty
+ ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) }
+
tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr')
- <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty ->
+ <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
-- See Note [More instantiated than scoped] in TcBinds
tcMonoExprNC expr res_ty
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
-tcExpr (HsIf pred b1 b2) res_ty
- = do { pred' <- tcMonoExpr pred boolTy
- ; b1' <- tcMonoExpr b1 res_ty
- ; b2' <- tcMonoExpr b2 res_ty
- ; return (HsIf pred' b1' b2') }
+tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
+ = do { pred' <- tcMonoExpr pred boolTy
+ ; b1' <- tcMonoExpr b1 res_ty
+ ; b2' <- tcMonoExpr b2 res_ty
+ ; return (HsIf Nothing pred' b1' b2') }
+
+tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
+ = do { pred_ty <- newFlexiTyVarTy openTypeKind
+ ; b1_ty <- newFlexiTyVarTy openTypeKind
+ ; b2_ty <- newFlexiTyVarTy openTypeKind
+ ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
+ ; fun' <- tcSyntaxOp IfOrigin fun if_ty
+ ; pred' <- tcMonoExpr pred pred_ty
+ ; b1' <- tcMonoExpr b1 b1_ty
+ ; b2' <- tcMonoExpr b2 b2_ty
+ -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
+ -- so maybe we should use the code for function applications
+ -- (which would allow ifThenElse to be higher rank).
+ -- But it's a little awkward, so I'm leaving it alone for now
+ -- and it maintains uniformity with other rebindable syntax
+ ; return (HsIf (Just fun') pred' b1' b2') }
tcExpr (HsDo do_or_lc stmts body _) res_ty
= tcDoStmts do_or_lc stmts body res_ty
ptext (sLit "was found where an expression was expected")])
\end{code}
+Note [Rebindable syntax for if]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rebindable syntax for 'if' uses the most flexible possible type
+for conditionals:
+ ifThenElse :: p -> b1 -> b2 -> res
+to support expressions like this:
+
+ ifThenElse :: Maybe a -> (a -> b) -> b -> b
+ ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e
+
+ example :: String
+ example = if Just 2
+ then \v -> show v
+ else "No value"
+
+
%************************************************************************
%* *
Record construction and update
-- Typecheck the result, thereby propagating
-- info (if any) from result into the argument types
-- Both actual_res_ty and res_ty are deeply skolemised
- ; co_res <- unifyType actual_res_ty res_ty
+ ; co_res <- addErrCtxt (funResCtxt fun) $
+ unifyType actual_res_ty res_ty
-- Typecheck the arguments
; args1 <- tcArgs fun args expected_arg_tys
tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
-- Look up an occurrence of an Id, and instantiate it (deeply)
-tcInferIdWithOrig orig id_name
- = do { id <- lookup_id
- ; (id_expr, id_rho) <- instantiateOuter orig id
- ; (wrap, rho) <- deeplyInstantiate orig id_rho
- ; return (mkHsWrap wrap id_expr, rho) }
+tcInferIdWithOrig orig id_name =
+ do { id_level <- getIdLevel id_name
+ ; cur_level <- getHetMetLevel
+ ; if (length id_level < length cur_level)
+ then do { (lhexp, tcrho) <-
+ tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name))
+ ; return (unLoc lhexp, tcrho)
+ }
+ else tcInferIdWithOrig' orig id_name
+ }
+
+tcInferIdWithOrig' orig id_name =
+ do { id <- lookup_id
+ ; (id_expr, id_rho) <- instantiateOuter orig id
+ ; (wrap, rho) <- deeplyInstantiate orig id_rho
+ ; return (mkHsWrap wrap id_expr, rho) }
where
lookup_id :: TcM TcId
lookup_id
= do { thing <- tcLookup id_name
; case thing of
- ATcId { tct_id = id, tct_level = lvl }
+ ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel }
-> do { check_naughty id -- Note [Local record selectors]
; checkThLocalId id lvl
+ ; current_hetMetLevel <- getHetMetLevel
+ ; mapM
+ (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2))
+ (zip variable_hetMetLevel current_hetMetLevel)
; return id }
AGlobal (AnId id)
- -> do { check_naughty id; return id }
- -- A global cannot possibly be ill-staged
+ -> do { check_naughty id
+ ; return id }
+ -- A global cannot possibly be ill-staged in Template Haskell
-- nor does it need the 'lifting' treatment
-- hence no checkTh stuff here
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
+funResCtxt :: LHsExpr Name -> SDoc
+funResCtxt fun
+ = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+
badFieldTypes :: [(Name,TcType)] -> SDoc
badFieldTypes prs
= hang (ptext (sLit "Record update for insufficiently polymorphic field")
projects / ghc-hetmet.git / blobdiff