import TysPrim
import Coercion ( mkSymCoI )
import Outputable
-import VarSet
import BasicTypes ( Arity )
import Util
import SrcLoc
; checkArgs fun_name matches
; (wrap_gen, (wrap_fun, group))
- <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho ->
+ <- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho ->
-- Note [Polymorphic expected type for tcMatchesFun]
matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
where
tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
= add_match_ctxt match $
- do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
+ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
; return (Match pats' Nothing grhss') }
tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
case maybeByExpr of
Nothing -> do
-- We must validate that usingExpr :: forall a. [a] -> [a]
- usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy))
+ let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
+ usingExpr' <- tcPolyExpr usingExpr using_ty
return (usingExpr', Nothing)
Just byExpr -> do
- -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
+ -- We must infer a type such that e :: t and then check that
+ -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
(byExpr', tTy) <- tcInferRhoNC byExpr
- usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
+ let using_ty = mkForAllTy alphaTyVar $
+ (alphaTy `mkFunTy` tTy)
+ `mkFunTy` alphaListTy `mkFunTy` alphaListTy
+ usingExpr' <- tcPolyExpr usingExpr using_ty
return (usingExpr', Just byExpr')
binders' <- tcLookupLocalIds binders
; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
- (by', using_ty) <- case by of
- Nothing -> -- check that using :: forall a. [a] -> [[a]]
- return (Nothing, mkForAllTy alphaTyVar $
- alphaListTy `mkFunTy` alphaListListTy)
-
- Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
- -- where by :: t
- do { (by_e', t_ty) <- tcInferRhoNC by_e
- ; return (Just by_e', mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` t_ty)
- `mkFunTy` alphaListTy
- `mkFunTy` alphaListListTy) }
+ (by', using_ty) <-
+ case by of
+ Nothing -> -- check that using :: forall a. [a] -> [[a]]
+ return (Nothing, mkForAllTy alphaTyVar $
+ alphaListTy `mkFunTy` alphaListListTy)
+
+ Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
+ -- where by :: t
+ do { (by_e', t_ty) <- tcInferRhoNC by_e
+ ; return (Just by_e', mkForAllTy alphaTyVar $
+ (alphaTy `mkFunTy` t_ty)
+ `mkFunTy` alphaListTy
+ `mkFunTy` alphaListListTy) }
-- Find the Ids (and hence types) of all old binders
bndr_ids <- tcLookupLocalIds bndr_names
return (bndr_ids, by', using_ty, elt_ty')
- -- Ensure that every old binder of type b is linked up with its new binder which should have type [b]
+ -- Ensure that every old binder of type b is linked up with
+ -- its new binder which should have type [b]
; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
bindersMap' = bndr_ids `zip` list_bndr_ids
-- See Note [GroupStmt binder map] in HsExpr
Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
- -- Type check the thing in the environment with these new binders and return the result
+ -- Type check the thing in the environment with
+ -- these new binders and return the result
; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
; return (GroupStmt stmts' bindersMap' by' using', thing) }
where
alphaListListTy = mkTyConApp m_tc [alphaListTy]
mk_list_bndr :: Name -> TcId -> TcId
- mk_list_bndr list_bndr_name bndr_id = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
+ mk_list_bndr list_bndr_name bndr_id
+ = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
tcLcStmt _ _ stmt _ _
= pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside new_res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-> TcStmtChecker
tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
args_in_match :: LMatch Name -> Int
args_in_match (L _ (Match pats _ _)) = length pats
-checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty
+checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
\end{code}
projects / ghc-hetmet.git / blobdiff