3 TcM(..), NF_TcM(..), TcDown, TcEnv,
7 returnTc, thenTc, thenTc_, mapTc, listTc,
8 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
9 mapBagTc, fixTc, tryTc,
11 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
12 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
14 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
15 failTc, warnTc, recoverTc, recoverNF_Tc,
18 tcGetDefaultTys, tcSetDefaultTys,
19 tcGetUnique, tcGetUniques,
21 tcAddSrcLoc, tcGetSrcLoc,
22 tcAddErrCtxtM, tcSetErrCtxtM,
23 tcAddErrCtxt, tcSetErrCtxt,
25 tcNewMutVar, tcReadMutVar, tcWriteMutVar,
29 TcError(..), TcWarning(..),
33 MutableVar(..), _MutableArray
38 import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
40 import Type ( Type(..), GenType )
41 import TyVar ( TyVar(..), GenTyVar )
42 import Usage ( Usage(..), GenUsage )
43 import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
48 --LATER:import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
50 import Bag ( Bag, emptyBag, isEmptyBag,
51 foldBag, unitBag, unionBags, snocBag )
52 import FiniteMap ( FiniteMap, emptyFM )
53 --import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
54 import ErrUtils ( Error(..) )
55 import Maybes ( MaybeErr(..) )
56 --import Name ( Name )
57 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
58 import UniqFM ( UniqFM, emptyUFM )
59 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
60 import Unique ( Unique )
63 import PprStyle ( PprStyle(..) )
65 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
69 \section{TcM, NF_TcM: the type checker monads}
70 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
73 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
74 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
78 -- With a builtin polymorphic type for _runSST the type for
79 -- initTc should use TcM s r instead of TcM _RealWorld r
83 -> MaybeErr (r, Bag Warning)
84 (Bag Error, Bag Warning)
88 newMutVarSST us `thenSST` \ us_var ->
89 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
90 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
92 init_down = TcDown [] us_var
95 init_env = initEnv tvs_var
98 (\_ -> returnSST Nothing)
99 (do_this init_down init_env `thenFSST` \ res ->
100 returnFSST (Just res))
101 `thenSST` \ maybe_res ->
102 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
103 case (maybe_res, isEmptyBag errs) of
104 (Just res, True) -> returnSST (Succeeded (res, warns))
105 _ -> returnSST (Failed (errs, warns))
108 thenNF_Tc :: NF_TcM s a
109 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
110 -> TcDown s -> TcEnv s -> State# s -> b
111 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
112 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
114 thenNF_Tc m k down env
115 = m down env `thenSST` \ r ->
118 thenNF_Tc_ :: NF_TcM s a
119 -> (TcDown s -> TcEnv s -> State# s -> b)
120 -> TcDown s -> TcEnv s -> State# s -> b
121 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
122 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
124 thenNF_Tc_ m k down env
125 = m down env `thenSST_` k down env
127 returnNF_Tc :: a -> NF_TcM s a
128 returnNF_Tc v down env = returnSST v
130 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
131 mapNF_Tc f [] = returnNF_Tc []
132 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
133 mapNF_Tc f xs `thenNF_Tc` \ rs ->
136 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
137 listNF_Tc [] = returnNF_Tc []
138 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
139 listNF_Tc xs `thenNF_Tc` \ rs ->
142 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
144 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
145 b2 `thenNF_Tc` \ r2 ->
146 returnNF_Tc (unionBags r1 r2))
147 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
148 (returnNF_Tc emptyBag)
151 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
152 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
153 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
154 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
155 returnNF_Tc (r1:rs1, r2:rs2)
157 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
159 = m down env `thenFSST` \ r ->
162 thenTc_ :: TcM s a -> TcM s b -> TcM s b
164 = m down env `thenFSST_` k down env
166 returnTc :: a -> TcM s a
167 returnTc val down env = returnFSST val
169 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
170 mapTc f [] = returnTc []
171 mapTc f (x:xs) = f x `thenTc` \ r ->
172 mapTc f xs `thenTc` \ rs ->
175 listTc :: [TcM s a] -> TcM s [a]
176 listTc [] = returnTc []
177 listTc (x:xs) = x `thenTc` \ r ->
178 listTc xs `thenTc` \ rs ->
181 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
182 foldrTc k z [] = returnTc z
183 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
186 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
187 foldlTc k z [] = returnTc z
188 foldlTc k z (x:xs) = k z x `thenTc` \r ->
191 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
192 mapAndUnzipTc f [] = returnTc ([],[])
193 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
194 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
195 returnTc (r1:rs1, r2:rs2)
197 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
198 mapAndUnzip3Tc f [] = returnTc ([],[],[])
199 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
200 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
201 returnTc (r1:rs1, r2:rs2, r3:rs3)
203 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
205 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
207 returnTc (unionBags r1 r2))
208 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
212 fixTc :: (a -> TcM s a) -> TcM s a
213 fixTc m env down = fixFSST (\ loop -> m loop env down)
216 @forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
217 This elegantly ensures that it can't zap any type variables that
218 belong to the main thread. We throw away any error messages!
221 forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
222 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
223 = -- Get a fresh unique supply
224 readMutVarSST u_var `thenSST` \ us ->
226 (us1, us2) = splitUniqSupply us
228 writeMutVarSST u_var us1 `thenSST_`
230 newMutVarSST us2 `thenSST` \ u_var' ->
231 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
232 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
234 down' = TcDown deflts us_var src_loc err_cxt err_var'
235 env' = forkEnv env tv_var'
239 -- ToDo: optionally dump any error messages
243 @forkTcDown@ makes a new "down" blob for a lazily-computed fork
247 forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
248 = -- Get a fresh unique supply
249 readMutVarSST u_var `thenSST` \ us ->
251 (us1, us2) = splitUniqSupply us
253 writeMutVarSST u_var us1 `thenSST_`
255 -- Make fresh MutVars for the unique supply and errors
256 newMutVarSST us2 `thenSST` \ u_var' ->
257 newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
260 returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
267 failTc :: Message -> TcM s a
268 failTc err_msg down env
269 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
270 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
272 err = mkTcErr loc ctxt_msgs err_msg
274 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
277 errs_var = getTcErrs down
278 ctxt = getErrCtxt down
281 warnTc :: Bool -> Message -> NF_TcM s ()
282 warnTc warn_if_true warn down env
283 = if warn_if_true then
284 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
285 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
290 errs_var = getTcErrs down
292 recoverTc :: TcM s r -> TcM s r -> TcM s r
293 recoverTc recover m down env
294 = recoverFSST (\ _ -> recover down env) (m down env)
296 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
297 recoverNF_Tc recover m down env
298 = recoverSST (\ _ -> recover down env) (m down env)
300 -- (tryTc r m) tries m; if it succeeds it returns it,
301 -- otherwise it returns r. Any error messages added by m are discarded,
302 -- whether or not m succeeds.
303 tryTc :: TcM s r -> TcM s r -> TcM s r
304 tryTc recover m down env
305 = recoverFSST (\ _ -> recover down env) $
306 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
307 m (setTcErrs down new_errs_var) env
309 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
310 checkTc True err = returnTc ()
311 checkTc False err = failTc err
313 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
314 checkTcM True err = returnTc ()
315 checkTcM False err = err
317 checkMaybeTc :: Maybe val -> Message -> TcM s val
318 checkMaybeTc (Just val) err = returnTc val
319 checkMaybeTc Nothing err = failTc err
321 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
322 checkMaybeTcM (Just val) err = returnTc val
323 checkMaybeTcM Nothing err = err
329 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
330 tcNewMutVar val down env = newMutVarSST val
332 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
333 tcWriteMutVar var val down env = writeMutVarSST var val
335 tcReadMutVar :: MutableVar s a -> NF_TcM s a
336 tcReadMutVar var down env = readMutVarSST var
343 tcGetEnv :: NF_TcM s (TcEnv s)
344 tcGetEnv down env = returnSST env
346 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
347 tcSetEnv new_env m down old_env = m down new_env
354 tcGetDefaultTys :: NF_TcM s [Type]
355 tcGetDefaultTys down env = returnSST (getDefaultTys down)
357 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
358 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
360 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
361 tcAddSrcLoc loc m down env = m (setLoc down loc) env
363 tcGetSrcLoc :: NF_TcM s SrcLoc
364 tcGetSrcLoc down env = returnSST (getLoc down)
366 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
367 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
368 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
370 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
371 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
372 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
379 tcGetUnique :: NF_TcM s Unique
381 = readMutVarSST u_var `thenSST` \ uniq_supply ->
383 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
384 uniq = getUnique uniq_s
386 writeMutVarSST u_var new_uniq_supply `thenSST_`
389 u_var = getUniqSupplyVar down
391 tcGetUniques :: Int -> NF_TcM s [Unique]
392 tcGetUniques n down env
393 = readMutVarSST u_var `thenSST` \ uniq_supply ->
395 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
396 uniqs = getUniques n uniq_s
398 writeMutVarSST u_var new_uniq_supply `thenSST_`
401 u_var = getUniqSupplyVar down
411 [Type] -- Types used for defaulting
413 (MutableVar s UniqSupply) -- Unique supply
415 SrcLoc -- Source location
416 (ErrCtxt s) -- Error context
417 (MutableVar s (Bag Warning,
420 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
421 -- to deal with bound type variables just before error
422 -- message construction
425 -- These selectors are *local* to TcMonad.lhs
428 getTcErrs (TcDown def us loc ctxt errs) = errs
429 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
431 getDefaultTys (TcDown def us loc ctxt errs) = def
432 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
434 getLoc (TcDown def us loc ctxt errs) = loc
435 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
437 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
439 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
440 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
441 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
449 rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)"
451 rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
453 rn4MtoTcM name_funs rn_action down env
454 = readMutVarSST u_var `thenSST` \ uniq_supply ->
456 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
458 writeMutVarSST u_var new_uniq_supply `thenSST_`
461 = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
463 returnSST (rn_result, rn_errs)
465 u_var = getUniqSupplyVar down
474 type TcError = Message
475 type TcWarning = Message
477 mkTcErr :: SrcLoc -- Where
478 -> [Message] -- Context
479 -> Message -- What went wrong
480 -> TcError -- The complete error report
482 mkTcErr locn ctxt msg sty
483 = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
484 4 (ppAboves [msg sty | msg <- ctxt])
487 arityErr kind name n m sty
488 = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
489 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
491 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
492 quantity | m < n = "few"
494 n_arguments | n == 0 = ppStr "no arguments"
495 | n == 1 = ppStr "1 argument"
496 | True = ppCat [ppInt n, ppStr "arguments"]