projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix Trac #3261: make default types play nice with -Werror
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcMatches.lhs
diff --git
a/compiler/typecheck/TcMatches.lhs
b/compiler/typecheck/TcMatches.lhs
index
b16c8d3
..
db9089c
100644
(file)
--- a/
compiler/typecheck/TcMatches.lhs
+++ b/
compiler/typecheck/TcMatches.lhs
@@
-12,7
+12,7
@@
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
-import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr )
import HsSyn
import TcRnMonad
import HsSyn
import TcRnMonad
@@
-36,6
+36,8
@@
import SrcLoc
import FastString
import Control.Monad
import FastString
import Control.Monad
+
+#include "HsVersions.h"
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-71,7
+73,7
@@
tcMatchesFun fun_name inf matches exp_ty
-- 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.
- ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
+ ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
}
where
tcMatches match_ctxt pat_tys rhs_ty matches
}
where
@@
-92,11
+94,18
@@
tcMatchesCase :: TcMatchCtxt -- Case context
-> TcM (MatchGroup TcId) -- Translated alternatives
tcMatchesCase ctxt scrut_ty matches res_ty
-> TcM (MatchGroup TcId) -- Translated alternatives
tcMatchesCase ctxt scrut_ty matches res_ty
+ | 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
- = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
+ = subFunTys doc n_pats res_ty Nothing $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
n_pats = matchGroupArity match
tcMatches match_ctxt pat_tys rhs_ty match
where
n_pats = matchGroupArity match
@@
-141,7
+150,8
@@
data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
-> TcM (LHsExpr TcId) }
tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
-> TcM (LHsExpr TcId) }
tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
- = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
+ = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
+ do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
-------------
; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
-------------
@@
-156,7
+166,7
@@
tcMatch ctxt pat_tys rhs_ty match
where
tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
= add_match_ctxt match $
where
tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
= add_match_ctxt match $
- do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
+ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
tc_grhss ctxt maybe_rhs_sig grhss
; return (Match pats' Nothing grhss') }
tc_grhss ctxt maybe_rhs_sig grhss
; return (Match pats' Nothing grhss') }
@@
-257,7
+267,7
@@
tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
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)
- ; body' <- tcPolyExpr body res_ty
+ ; body' <- tcMonoExpr body res_ty
; return body'
}
\end{code}
; return body'
}
\end{code}
@@
-316,9
+326,9
@@
tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
; thing <- thing_inside res_ty
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
; thing <- thing_inside res_ty
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
-tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
- ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
+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 thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt _ stmt _ _
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt _ stmt _ _
@@
-332,10
+342,10
@@
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
-- A generator, pat <- rhs
-> TcStmtChecker
-- A generator, pat <- rhs
-tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
tcMonoExpr rhs (mkTyConApp m_tc [ty])
= do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
tcMonoExpr rhs (mkTyConApp m_tc [ty])
- ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
@@
-394,7
+404,7
@@
tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_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]
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]
- (byExpr', tTy) <- tcInferRho byExpr
+ (byExpr', tTy) <- tcInferRhoNC byExpr
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')
@@
-418,7
+428,7
@@
tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_in
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
- (byExpr', tTy) <- tcInferRho byExpr
+ (byExpr', tTy) <- tcInferRhoNC byExpr
-- 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))
@@
-453,8
+463,8
@@
tcLcStmt _ _ stmt _ _
tcDoStmt :: TcStmtChecker
tcDoStmt :: TcStmtChecker
-tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+tcDoStmt ctxt (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> }
@@
-479,13
+489,13
@@
tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
then return noSyntaxExpr
else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
then return noSyntaxExpr
else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
- ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
- = do { (rhs', rhs_ty) <- tcInferRho rhs
+ = 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) <-
@@
-512,9
+522,9
@@
tcDoStmt _ stmt _ _
tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
-> TcStmtChecker
tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
-> TcStmtChecker
-tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside
+tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_rhs rhs
= do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside