-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
tcStmts, tcDoStmts, tcBody,
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
tcStmts, tcDoStmts, tcBody,
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
-import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr )
-- This is one of two places places we call subFunTys
-- The point is that if expected_y is a "hole", we want
-- to make pat_tys and rhs_ty as "holes" too.
-- This is one of two places places we call subFunTys
-- The point is that if expected_y is a "hole", we want
-- to make pat_tys and rhs_ty as "holes" too.
+ | isEmptyMatchGroup matches
+ = -- Allow empty case expressions
+ do { -- Make sure we follow the invariant that res_ty is filled in
+ res_ty' <- refineBoxToTau res_ty
+ ; return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
+
+ | otherwise
= tcMatches ctxt [scrut_ty] res_ty matches
tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
tcMatchLambda match res_ty
= tcMatches ctxt [scrut_ty] res_ty matches
tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
tcMatchLambda match res_ty
- tc_grhss ctxt (Just res_sig) grhss rhs_ty
- = do { addErr (ptext (sLit "Ignoring (deprecated) result type signature")
- <+> ppr res_sig)
- ; tcGRHSs ctxt grhss rhs_ty }
+ tc_grhss _ (Just {}) _ _
+ = panic "tc_ghrss" -- Rejected by renamer
-- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
-- so we don't want to add "In the lambda abstraction \x->e"
add_match_ctxt match thing_inside
= case mc_what ctxt of
LambdaExpr -> thing_inside
-- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
-- so we don't want to add "In the lambda abstraction \x->e"
add_match_ctxt match thing_inside
= case mc_what ctxt of
LambdaExpr -> thing_inside
tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
= do { traceTc (text "tcBody" <+> ppr res_ty)
tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
= do { traceTc (text "tcBody" <+> ppr res_ty)
tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <-
setSrcSpan loc $
tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <-
setSrcSpan loc $
= do { guard' <- tcMonoExpr guard boolTy
; thing <- thing_inside res_ty
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
= do { guard' <- tcMonoExpr guard boolTy
; thing <- thing_inside res_ty
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
-tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
= do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
tcMonoExpr rhs (mkTyConApp m_tc [ty])
; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
= do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
tcMonoExpr rhs (mkTyConApp m_tc [ty])
; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
= do { rhs' <- tcMonoExpr rhs boolTy
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
= do { rhs' <- tcMonoExpr rhs boolTy
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
loop ((stmts, names) : pairs)
= do { (stmts', (ids, pairs', thing))
loop ((stmts, names) : pairs)
= do { (stmts', (ids, pairs', thing))
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
do { ids <- tcLookupLocalIds names
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
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]
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]
usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
return (usingExpr', Just byExpr')
usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
return (usingExpr', Just byExpr')
tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
-- We must infer a type such that byExpr :: t
tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
-- We must infer a type such that byExpr :: t
-- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
-- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
associateNewBinder :: TcId -> Name -> TcId
associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
associateNewBinder :: TcId -> Name -> TcId
associateNewBinder oldBinder newBinder = mkLocalId newBinder (mkTyConApp m_tc [idType oldBinder])
-tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- We should use type *inference* for the RHS computations,
-- becuase of GADTs.
-- do { pat <- rhs; <rest> }
-- We should use type *inference* for the RHS computations,
-- becuase of GADTs.
-- do { pat <- rhs; <rest> }
-tcDoStmt ctxt (ExprStmt rhs then_op _) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
+ = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
; (then_op', new_res_ty) <-
-- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
; (then_op', new_res_ty) <-
; thing <- thing_inside new_res_ty
; return (ExprStmt rhs' then_op' rhs_ty, thing) }
; thing <- thing_inside new_res_ty
; return (ExprStmt rhs' then_op' rhs_ty, thing) }
= failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
-- This case can't be caught in the renamer
-- see RnExpr.checkRecStmt
= failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
-- This case can't be caught in the renamer
-- see RnExpr.checkRecStmt
= do { (rhs', pat_ty) <- tc_rhs rhs
; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
= do { (rhs', pat_ty) <- tc_rhs rhs
; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
= do { (rhs', elt_ty) <- tc_rhs rhs
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
= do { (rhs', elt_ty) <- tc_rhs rhs
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
{ (stmts', (later_ids, rec_rets))
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
{ (stmts', (later_ids, rec_rets))
-- ToDo: res_ty not really right
do { rec_rets <- zipWithM tc_ret recNames rec_tys
; later_ids <- tcLookupLocalIds laterNames
-- ToDo: res_ty not really right
do { rec_rets <- zipWithM tc_ret recNames rec_tys
; later_ids <- tcLookupLocalIds laterNames