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 ( SYN_IE(RenamedMatch), RnName{-instance Outputable-} )
17 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
19 import TcMonad hiding ( rnMtoTcM )
20 import Inst ( Inst, SYN_IE(LIE), plusLIE )
21 import TcEnv ( newMonoIds )
22 IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
23 import TcPat ( tcPat )
24 import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
25 import Unify ( unifyTauTy, unifyTauTyList )
27 import Kind ( Kind, mkTypeKind )
29 import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
33 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
34 @FunMonoBind@. The second argument is the name of the function, which
35 is used in error messages. It checks that all the equations have the
36 same number of arguments before using @tcMatches@ to do the work.
39 tcMatchesFun :: RnName
40 -> TcType s -- Expected type
42 -> TcM s ([TcMatch s], LIE s)
44 tcMatchesFun fun_name expected_ty matches@(first_match:_)
45 = -- Set the location to that of the first equation, so that
46 -- any inter-equation error messages get some vaguely
47 -- sensible location. Note: we have to do this odd
48 -- ann-grabbing, because we don't always have annotations in
49 -- hand when we call tcMatchesFun...
51 tcAddSrcLoc (get_Match_loc first_match) (
53 -- Check that they all have the same no of arguments
54 checkTc (all_same (noOfArgs matches))
55 (varyingArgsErr fun_name matches) `thenTc_`
57 -- ToDo: Don't use "expected" stuff if there ain't a type signature
58 -- because inconsistency between branches
59 -- may show up as something wrong with the (non-existent) type signature
61 -- We need to substitute so that we can see as much about the type as possible
62 zonkTcType expected_ty `thenNF_Tc` \ expected_ty' ->
63 tcMatchesExpected expected_ty' (MFun fun_name) matches
67 all_same :: [Int] -> Bool
68 all_same [] = True -- Should never happen (ToDo: panic?)
70 all_same (x:xs) = all ((==) x) xs
73 @tcMatchesCase@ doesn't do the argument-count check because the
74 parser guarantees that each equation has exactly one argument.
77 tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
78 tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
83 data FunOrCase = MCase | MFun RnName -- Records whether doing fun or case rhss;
84 -- used to produced better error messages
86 tcMatchesExpected :: TcType s
89 -> TcM s ([TcMatch s], LIE s)
91 tcMatchesExpected expected_ty fun_or_case [match]
92 = tcAddSrcLoc (get_Match_loc match) $
93 tcAddErrCtxt (matchCtxt fun_or_case match) $
94 tcMatchExpected expected_ty match `thenTc` \ (match', lie) ->
95 returnTc ([match'], lie)
97 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
98 = tcAddSrcLoc (get_Match_loc match1) (
99 tcAddErrCtxt (matchCtxt fun_or_case match1) $
100 tcMatchExpected expected_ty match1
101 ) `thenTc` \ (match1', lie1) ->
102 tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
103 returnTc (match1' : matches', plusLIE lie1 lie2)
105 tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
108 = tcAddSrcLoc (get_Match_loc match) $
109 tcMatch match `thenTc` \ (match', lie, ty) ->
110 returnTc ([match'], lie, [ty])
112 tcMatches (match1 : matches)
113 = tcAddSrcLoc (get_Match_loc match1) (
115 ) `thenTc` \ (match1', lie1, match1_ty) ->
116 tcMatches matches `thenTc` \ (matches', lie2, matches_ty) ->
117 returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
122 :: TcType s -- This gives the expected
123 -- result-type of the Match. Early unification
124 -- with this guy gives better error messages
126 -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
129 tcMatchExpected expected_ty the_match@(PatMatch pat match)
130 = case getFunTy_maybe expected_ty of
132 Nothing -> -- Not a function type (eg type variable)
133 -- So use tcMatch instead
134 tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
135 unifyTauTy expected_ty match_ty `thenTc_`
136 returnTc (match', lie_match)
138 Just (arg_ty,rest_ty) -> -- It's a function type!
139 let binders = collectPatBinders pat
141 newMonoIds binders mkTypeKind (\ _ ->
142 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
143 unifyTauTy pat_ty arg_ty `thenTc_`
144 tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
145 returnTc (PatMatch pat' match',
146 plusLIE lie_pat lie_match)
149 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
150 = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
151 unifyTauTy expected_ty grhss_ty `thenTc_`
152 returnTc (GRHSMatch grhss_and_binds', lie)
154 tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
156 tcMatch (PatMatch pat match)
157 = let binders = collectPatBinders pat
159 newMonoIds binders mkTypeKind (\ _ ->
160 -- NB TypeKind; lambda-bound variables are allowed
161 -- to unify with unboxed types.
163 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
164 tcMatch match `thenTc` \ (match', lie_match, match_ty) ->
165 returnTc (PatMatch pat' match',
166 plusLIE lie_pat lie_match,
167 mkFunTy pat_ty match_ty)
170 tcMatch (GRHSMatch grhss_and_binds)
171 = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
172 returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
176 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
177 many arguments were used in each of the equations. This is used to
178 report a sensible error message when different equations have
179 different numbers of arguments.
182 noOfArgs :: [RenamedMatch] -> [Int]
184 noOfArgs ms = map args_in_match ms
186 args_in_match :: RenamedMatch -> Int
187 args_in_match (GRHSMatch _) = 0
188 args_in_match (PatMatch _ match) = 1 + args_in_match match
191 @get_Match_loc@ takes a @RenamedMatch@ and returns the
192 source-location gotten from the GRHS inside.
193 THis is something of a nuisance, but no more.
196 get_Match_loc :: RenamedMatch -> SrcLoc
198 get_Match_loc (PatMatch _ m) = get_Match_loc m
199 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
202 get_GRHS_loc (OtherwiseGRHS _ locn) = locn
203 get_GRHS_loc (GRHS _ _ locn) = locn
209 matchCtxt MCase match sty
210 = ppHang (ppStr "In a \"case\" branch:")
211 4 (pprMatch sty True{-is_case-} match)
213 matchCtxt (MFun fun) match sty
214 = ppHang (ppBesides [ppStr "In an equation for function ", ppr sty fun, ppChar ':'])
215 4 (ppBesides [ppr sty fun, ppSP, pprMatch sty False{-not case-} match])
220 varyingArgsErr name matches sty
221 = ppSep [ppStr "Varying number of arguments for function", ppr sty name]