Commit 5cbe218e authored by sof's avatar sof
Browse files

[project @ 1997-07-26 03:31:48 by sof]

removed: tcMatch
parent 85bd8439
......@@ -6,7 +6,7 @@
\begin{code}
#include "HsVersions.h"
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchExpected ) where
IMP_Ubiq()
......@@ -21,15 +21,15 @@ import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
Sig, HsLit, DoOrListComp, Fixity, HsType, ArithSeqInfo,
collectPatBinders, pprMatch )
import RnHsSyn ( SYN_IE(RenamedMatch) )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
import TcHsSyn ( SYN_IE(TcMatch) )
import TcMonad
import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcEnv ( newMonoIds )
import TcPat ( tcPat )
import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, zonkTcType )
import TcSimplify ( bindInstsOfLocalFuns )
import Unify ( unifyTauTy, unifyTauTyList )
import Unify ( unifyTauTy, unifyTauTyList, unifyFunTy )
import Name ( Name {- instance Outputable -} )
import Kind ( Kind, mkTypeKind )
......@@ -114,20 +114,6 @@ tcMatchesExpected expected_ty fun_or_case (match1 : matches)
) `thenTc` \ (match1', lie1) ->
tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
returnTc (match1' : matches', plusLIE lie1 lie2)
tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
tcMatches [match]
= tcAddSrcLoc (get_Match_loc match) $
tcMatch match `thenTc` \ (match', lie, ty) ->
returnTc ([match'], lie, [ty])
tcMatches (match1 : matches)
= tcAddSrcLoc (get_Match_loc match1) (
tcMatch match1
) `thenTc` \ (match1', lie1, match1_ty) ->
tcMatches matches `thenTc` \ (matches', lie2, matches_ty) ->
returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
\end{code}
\begin{code}
......@@ -140,71 +126,42 @@ tcMatchExpected
-- in instead!
tcMatchExpected expected_ty the_match@(PatMatch pat match)
= case getFunTy_maybe expected_ty of
Nothing -> -- Not a function type (eg type variable)
-- So use tcMatch instead
tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
unifyTauTy expected_ty match_ty `thenTc_`
returnTc (match', lie_match)
Just (arg_ty,rest_ty) -> -- It's a function type!
let binders = collectPatBinders pat
in
newMonoIds binders mkTypeKind (\ mono_ids ->
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
unifyTauTy pat_ty arg_ty `thenTc_`
tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
-- In case there are any polymorpic, overloaded binders in the pattern
-- (which can happen in the case of rank-2 type signatures, or data constructors
-- with polymorphic arguments), we must dd a bindInstsOfLocalFns here
--
-- 99% of the time there are no bindings. In the unusual case we
-- march down the match to dump them in the right place (boring but easy).
bindInstsOfLocalFuns lie_match mono_ids `thenTc` \ (lie_match', inst_mbinds) ->
let
inst_binds = MonoBind inst_mbinds [] False
match'' = case inst_mbinds of
EmptyMonoBinds -> match'
other -> glue_on match'
glue_on (PatMatch p m) = PatMatch p (glue_on m)
glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
= (GRHSMatch (GRHSsAndBindsOut grhss
(inst_binds `ThenBinds` binds)
ty))
glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
in
returnTc (PatMatch pat' match'',
plusLIE lie_pat lie_match')
)
= unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
let binders = collectPatBinders pat
in
newMonoIds binders mkTypeKind (\ mono_ids ->
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
unifyTauTy pat_ty arg_ty `thenTc_`
tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
-- In case there are any polymorpic, overloaded binders in the pattern
-- (which can happen in the case of rank-2 type signatures, or data constructors
-- with polymorphic arguments), we must do a bindInstsOfLocalFns here
--
-- 99% of the time there are no bindings. In the unusual case we
-- march down the match to dump them in the right place (boring but easy).
bindInstsOfLocalFuns lie_match mono_ids `thenTc` \ (lie_match', inst_mbinds) ->
let
inst_binds = MonoBind inst_mbinds [] False
match'' = case inst_mbinds of
EmptyMonoBinds -> match'
other -> glue_on match'
glue_on (PatMatch p m) = PatMatch p (glue_on m)
glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
= (GRHSMatch (GRHSsAndBindsOut grhss
(inst_binds `ThenBinds` binds)
ty))
glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
in
returnTc (PatMatch pat' match'',
plusLIE lie_pat lie_match')
)
tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
= tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
= tcGRHSsAndBinds expected_ty grhss_and_binds `thenTc` \ (grhss_and_binds', lie) ->
checkTc (isTauTy expected_ty)
lurkingRank2SigErr `thenTc_`
unifyTauTy expected_ty grhss_ty `thenTc_`
returnTc (GRHSMatch grhss_and_binds', lie)
tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
tcMatch (PatMatch pat match)
= let binders = collectPatBinders pat
in
newMonoIds binders mkTypeKind (\ _ ->
-- NB TypeKind; lambda-bound variables are allowed
-- to unify with unboxed types.
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
tcMatch match `thenTc` \ (match', lie_match, match_ty) ->
returnTc (PatMatch pat' match',
plusLIE lie_pat lie_match,
mkFunTy pat_ty match_ty)
)
tcMatch (GRHSMatch grhss_and_binds)
= tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
\end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment