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, Stmt,
15 collectPatBinders, pprMatch )
16 import RnHsSyn ( SYN_IE(RenamedMatch) )
17 import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
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 )
26 import Name ( Name {- instance Outputable -} )
28 import Kind ( Kind, mkTypeKind )
30 import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
33 #if __GLASGOW_HASKELL__ >= 202
34 import SrcLoc (SrcLoc)
39 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
40 @FunMonoBind@. The second argument is the name of the function, which
41 is used in error messages. It checks that all the equations have the
42 same number of arguments before using @tcMatches@ to do the work.
46 -> TcType s -- Expected type
48 -> TcM s ([TcMatch s], LIE s)
50 tcMatchesFun fun_name expected_ty matches@(first_match:_)
51 = -- Set the location to that of the first equation, so that
52 -- any inter-equation error messages get some vaguely
53 -- sensible location. Note: we have to do this odd
54 -- ann-grabbing, because we don't always have annotations in
55 -- hand when we call tcMatchesFun...
57 tcAddSrcLoc (get_Match_loc first_match) (
59 -- Check that they all have the same no of arguments
60 checkTc (all_same (noOfArgs matches))
61 (varyingArgsErr fun_name matches) `thenTc_`
63 -- ToDo: Don't use "expected" stuff if there ain't a type signature
64 -- because inconsistency between branches
65 -- may show up as something wrong with the (non-existent) type signature
67 -- We need to substitute so that we can see as much about the type as possible
68 zonkTcType expected_ty `thenNF_Tc` \ expected_ty' ->
69 tcMatchesExpected expected_ty' (MFun fun_name) matches
73 all_same :: [Int] -> Bool
74 all_same [] = True -- Should never happen (ToDo: panic?)
76 all_same (x:xs) = all ((==) x) xs
79 @tcMatchesCase@ doesn't do the argument-count check because the
80 parser guarantees that each equation has exactly one argument.
83 tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
84 tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
89 data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss;
90 -- used to produced better error messages
92 tcMatchesExpected :: TcType s
95 -> TcM s ([TcMatch s], LIE s)
97 tcMatchesExpected expected_ty fun_or_case [match]
98 = tcAddSrcLoc (get_Match_loc match) $
99 tcAddErrCtxt (matchCtxt fun_or_case match) $
100 tcMatchExpected expected_ty match `thenTc` \ (match', lie) ->
101 returnTc ([match'], lie)
103 tcMatchesExpected expected_ty fun_or_case (match1 : matches)
104 = tcAddSrcLoc (get_Match_loc match1) (
105 tcAddErrCtxt (matchCtxt fun_or_case match1) $
106 tcMatchExpected expected_ty match1
107 ) `thenTc` \ (match1', lie1) ->
108 tcMatchesExpected expected_ty fun_or_case matches `thenTc` \ (matches', lie2) ->
109 returnTc (match1' : matches', plusLIE lie1 lie2)
111 tcMatches :: [RenamedMatch] -> TcM s ([TcMatch s], LIE s, [TcType s])
114 = tcAddSrcLoc (get_Match_loc match) $
115 tcMatch match `thenTc` \ (match', lie, ty) ->
116 returnTc ([match'], lie, [ty])
118 tcMatches (match1 : matches)
119 = tcAddSrcLoc (get_Match_loc match1) (
121 ) `thenTc` \ (match1', lie1, match1_ty) ->
122 tcMatches matches `thenTc` \ (matches', lie2, matches_ty) ->
123 returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty)
128 :: TcType s -- This gives the expected
129 -- result-type of the Match. Early unification
130 -- with this guy gives better error messages
132 -> TcM s (TcMatch s,LIE s) -- NB No type returned, because it was passed
135 tcMatchExpected expected_ty the_match@(PatMatch pat match)
136 = case getFunTy_maybe expected_ty of
138 Nothing -> -- Not a function type (eg type variable)
139 -- So use tcMatch instead
140 tcMatch the_match `thenTc` \ (match', lie_match, match_ty) ->
141 unifyTauTy expected_ty match_ty `thenTc_`
142 returnTc (match', lie_match)
144 Just (arg_ty,rest_ty) -> -- It's a function type!
145 let binders = collectPatBinders pat
147 newMonoIds binders mkTypeKind (\ _ ->
148 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
149 unifyTauTy pat_ty arg_ty `thenTc_`
150 tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
151 returnTc (PatMatch pat' match',
152 plusLIE lie_pat lie_match)
155 tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
156 = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
157 unifyTauTy expected_ty grhss_ty `thenTc_`
158 returnTc (GRHSMatch grhss_and_binds', lie)
160 tcMatch :: RenamedMatch -> TcM s (TcMatch s, LIE s, TcType s)
162 tcMatch (PatMatch pat match)
163 = let binders = collectPatBinders pat
165 newMonoIds binders mkTypeKind (\ _ ->
166 -- NB TypeKind; lambda-bound variables are allowed
167 -- to unify with unboxed types.
169 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
170 tcMatch match `thenTc` \ (match', lie_match, match_ty) ->
171 returnTc (PatMatch pat' match',
172 plusLIE lie_pat lie_match,
173 mkFunTy pat_ty match_ty)
176 tcMatch (GRHSMatch grhss_and_binds)
177 = tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
178 returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty)
182 @noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
183 many arguments were used in each of the equations. This is used to
184 report a sensible error message when different equations have
185 different numbers of arguments.
188 noOfArgs :: [RenamedMatch] -> [Int]
190 noOfArgs ms = map args_in_match ms
192 args_in_match :: RenamedMatch -> Int
193 args_in_match (GRHSMatch _) = 0
194 args_in_match (PatMatch _ match) = 1 + args_in_match match
197 @get_Match_loc@ takes a @RenamedMatch@ and returns the
198 source-location gotten from the GRHS inside.
199 THis is something of a nuisance, but no more.
202 get_Match_loc :: RenamedMatch -> SrcLoc
204 get_Match_loc (PatMatch _ m) = get_Match_loc m
205 get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _))
208 get_GRHS_loc (OtherwiseGRHS _ locn) = locn
209 get_GRHS_loc (GRHS _ _ locn) = locn
215 matchCtxt MCase match sty
216 = hang (ptext SLIT("In a \"case\" branch:"))
217 4 (pprMatch sty True{-is_case-} match)
219 matchCtxt (MFun fun) match sty
220 = hang (hcat [ptext SLIT("In an equation for function "), ppr sty fun, char ':'])
221 4 (pprQuote sty $ \sty -> hcat [ppr sty fun, space, pprMatch sty False{-not case-} match])
226 varyingArgsErr name matches sty
227 = sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]