2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[TcMatches]{Typecheck some @Matches@}
7 #include "HsVersions.h"
9 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where
13 import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
14 HsExpr, HsBinds, OutPat, Fake,
15 collectPatBinders, pprMatch )
16 import RnHsSyn ( RenamedMatch(..) )
17 import TcHsSyn ( TcIdOcc(..), TcMatch(..) )
19 import TcMonad hiding ( rnMtoTcM )
20 import Inst ( Inst, LIE(..), plusLIE )
21 import TcEnv ( newMonoIds )
22 import TcLoop ( tcGRHSsAndBinds )
23 import TcPat ( tcPat )
24 import TcType ( TcType(..), TcMaybe, zonkTcType )
25 import Unify ( unifyTauTy, unifyTauTyList )
27 import Kind ( Kind, mkTypeKind )
29 import RnHsSyn ( RnName{-instance Outputable-} )
30 import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
34 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
35 @FunMonoBind@. The second argument is the name of the function, which
36 is used in error messages. It checks that all the equations have the
37 same number of arguments before using @tcMatches@ to do the work.
40 tcMatchesFun :: RnName
41 -> TcType s -- Expected type
43 -> TcM s ([TcMatch s], LIE s)
45 tcMatchesFun fun_name expected_ty matches@(first_match:_)
46 = -- Set the location to that of the first equation, so that
47 -- any inter-equation error messages get some vaguely
48 -- sensible location. Note: we have to do this odd
49 -- ann-grabbing, because we don't always have annotations in
50 -- hand when we call tcMatchesFun...
52 tcAddSrcLoc (get_Match_loc first_match) (
54 -- Check that they all have the same no of arguments
55 checkTc (all_same (noOfArgs matches))
56 (varyingArgsErr fun_name matches) `thenTc_`
58 -- ToDo: Don't use "expected" stuff if there ain't a type signature
59 -- because inconsistency between branches
60 -- may show up as something wrong with the (non-existent) type signature
62 -- We need to substitute so that we can see as much about the type as possible
63 zonkTcType expected_ty `thenNF_Tc` \ expected_ty' ->
64 tcMatchesExpected expected_ty' (MFun fun_name) matches
68 all_same :: [Int] -> Bool
69 all_same [] = True -- Should never happen (ToDo: panic?)
71 all_same (x:xs) = all ((==) x) xs
74 @tcMatchesCase@ doesn't do the argument-count check because the
75 parser guarantees that each equation has exactly one argument.
78 tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
79 tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
84 data FunOrCase = MCase | MFun RnName -- Records whether doing fun or case rhss;
85 -- used to produced better error messages
87 tcMatchesExpected :: TcType s
90 -> TcM s ([TcMatch s], LIE s)
92 tcMatchesExpected expected_ty fun_or_case [match]
93 = tcAddSrcLoc (get_Match_loc match) $
94 tcAddErrCtxt (matchCtxt fun_or_case match) $
95 tcMatchExpected expected_ty match `thenTc` \ (match', lie) ->
96 returnTc ([match'], lie)
98 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
99 = tcAddSrcLoc (get_Match_loc match1) (
100 tcAddErrCtxt (matchCtxt fun_or_case match1) $
101 tcMatchExpected expected_ty match1
102 ) `thenTc` \ (match1', lie1) ->
103 tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
104 returnTc (match1' : matches', plusLIE lie1 lie2)
106 tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
109 = tcAddSrcLoc (get_Match_loc match) $
110 tcMatch match `thenTc` \ (match', lie, ty) ->
111 returnTc ([match'], lie, [ty])
113 tcMatches (match1 : matches)
114 = tcAddSrcLoc (get_Match_loc match1) (
116 ) `thenTc` \ (match1', lie1, match1_ty) ->
117 tcMatches matches `thenTc` \ (matches', lie2, matches_ty) ->
118 returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
123 :: TcType s -- This gives the expected
124 -- result-type of the Match. Early unification
125 -- with this guy gives better error messages
127 -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
130 tcMatchExpected expected_ty the_match@(PatMatch pat match)
131 = case getFunTy_maybe expected_ty of
133 Nothing -> -- Not a function type (eg type variable)
134 -- So use tcMatch instead
135 tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
136 unifyTauTy match_ty expected_ty `thenTc_`
137 returnTc (match', lie_match)
139 Just (arg_ty,rest_ty) -> -- It's a function type!
140 let binders = collectPatBinders pat
142 newMonoIds binders mkTypeKind (\ _ ->
143 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
144 unifyTauTy arg_ty pat_ty `thenTc_`
145 tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
146 returnTc (PatMatch pat' match',
147 plusLIE lie_pat lie_match)
150 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
151 = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
152 unifyTauTy grhss_ty expected_ty `thenTc_`
153 returnTc (GRHSMatch grhss_and_binds', lie)
155 tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
157 tcMatch (PatMatch pat match)
158 = let binders = collectPatBinders pat
160 newMonoIds binders mkTypeKind (\ _ ->
161 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
162 tcMatch match `thenTc` \ (match', lie_match, match_ty) ->
163 returnTc (PatMatch pat' match',
164 plusLIE lie_pat lie_match,
165 mkFunTy pat_ty match_ty)
168 tcMatch (GRHSMatch grhss_and_binds)
169 = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
170 returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
174 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
175 many arguments were used in each of the equations. This is used to
176 report a sensible error message when different equations have
177 different numbers of arguments.
180 noOfArgs :: [RenamedMatch] -> [Int]
182 noOfArgs ms = map args_in_match ms
184 args_in_match :: RenamedMatch -> Int
185 args_in_match (GRHSMatch _) = 0
186 args_in_match (PatMatch _ match) = 1 + args_in_match match
189 @get_Match_loc@ takes a @RenamedMatch@ and returns the
190 source-location gotten from the GRHS inside.
191 THis is something of a nuisance, but no more.
194 get_Match_loc :: RenamedMatch -> SrcLoc
196 get_Match_loc (PatMatch _ m) = get_Match_loc m
197 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
200 get_GRHS_loc (OtherwiseGRHS _ locn) = locn
201 get_GRHS_loc (GRHS _ _ locn) = locn
207 matchCtxt MCase match sty
208 = ppHang (ppStr "In a \"case\" branch:")
209 4 (pprMatch sty True{-is_case-} match)
211 matchCtxt (MFun fun) match sty
212 = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':'])
213 4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match])
218 varyingArgsErr name matches sty
219 = ppSep [ppStr "Varying number of arguments for function", ppr sty name]