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(..), Message(..),
33 MutableVar(..), _MutableArray
37 import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
39 import Type ( Type(..), GenType )
40 import TyVar ( TyVar(..), GenTyVar )
41 import Usage ( Usage(..), GenUsage )
45 import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
47 import Bag ( Bag, emptyBag, isEmptyBag,
48 foldBag, unitBag, unionBags, snocBag )
49 import FiniteMap ( FiniteMap, emptyFM )
50 import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
51 import ErrUtils ( Error(..) )
52 import Maybes ( MaybeErr(..) )
54 import ProtoName ( ProtoName )
55 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
56 import UniqFM ( UniqFM, emptyUFM )
57 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
58 import Unique ( Unique )
61 import PprStyle ( PprStyle(..) )
63 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
67 \section{TcM, NF_TcM: the type checker monads}
68 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
72 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
76 -- With a builtin polymorphic type for _runSST the type for
77 -- initTc should use TcM s r instead of TcM _RealWorld r
81 -> MaybeErr (r, Bag TcWarning)
82 (Bag TcError, Bag TcWarning)
86 newMutVarSST us `thenSST` \ us_var ->
87 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
88 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
90 init_down = TcDown [] us_var
93 init_env = initEnv tvs_var
96 (\_ -> returnSST Nothing)
97 (do_this init_down init_env `thenFSST` \ res ->
98 returnFSST (Just res))
99 `thenSST` \ maybe_res ->
100 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
101 case (maybe_res, isEmptyBag errs) of
102 (Just res, True) -> returnSST (Succeeded (res, warns))
103 _ -> returnSST (Failed (errs, warns))
106 thenNF_Tc :: NF_TcM s a
107 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
108 -> TcDown s -> TcEnv s -> State# s -> b
109 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
110 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
112 thenNF_Tc m k down env
113 = m down env `thenSST` \ r ->
116 thenNF_Tc_ :: NF_TcM s a
117 -> (TcDown s -> TcEnv s -> State# s -> b)
118 -> TcDown s -> TcEnv s -> State# s -> b
119 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
120 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
122 thenNF_Tc_ m k down env
123 = m down env `thenSST_` k down env
125 returnNF_Tc :: a -> NF_TcM s a
126 returnNF_Tc v down env = returnSST v
128 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
129 mapNF_Tc f [] = returnNF_Tc []
130 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
131 mapNF_Tc f xs `thenNF_Tc` \ rs ->
134 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
135 listNF_Tc [] = returnNF_Tc []
136 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
137 listNF_Tc xs `thenNF_Tc` \ rs ->
140 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
142 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
143 b2 `thenNF_Tc` \ r2 ->
144 returnNF_Tc (unionBags r1 r2))
145 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
146 (returnNF_Tc emptyBag)
149 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
150 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
151 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
152 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
153 returnNF_Tc (r1:rs1, r2:rs2)
155 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
157 = m down env `thenFSST` \ r ->
160 thenTc_ :: TcM s a -> TcM s b -> TcM s b
162 = m down env `thenFSST_` k down env
164 returnTc :: a -> TcM s a
165 returnTc val down env = returnFSST val
167 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
168 mapTc f [] = returnTc []
169 mapTc f (x:xs) = f x `thenTc` \ r ->
170 mapTc f xs `thenTc` \ rs ->
173 listTc :: [TcM s a] -> TcM s [a]
174 listTc [] = returnTc []
175 listTc (x:xs) = x `thenTc` \ r ->
176 listTc xs `thenTc` \ rs ->
179 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
180 foldrTc k z [] = returnTc z
181 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
184 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
185 foldlTc k z [] = returnTc z
186 foldlTc k z (x:xs) = k z x `thenTc` \r ->
189 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
190 mapAndUnzipTc f [] = returnTc ([],[])
191 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
192 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
193 returnTc (r1:rs1, r2:rs2)
195 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
196 mapAndUnzip3Tc f [] = returnTc ([],[],[])
197 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
198 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
199 returnTc (r1:rs1, r2:rs2, r3:rs3)
201 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
203 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
205 returnTc (unionBags r1 r2))
206 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
210 fixTc :: (a -> TcM s a) -> TcM s a
211 fixTc m env down = fixFSST (\ loop -> m loop env down)
214 @forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
215 This elegantly ensures that it can't zap any type variables that
216 belong to the main thread. We throw away any error messages!
219 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
221 = forkTcDown down `thenSST` \ down' ->
222 returnSST (_runSST (m down' (forkTcEnv env)))
229 failTc :: Message -> TcM s a
230 failTc err_msg down env
231 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
232 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
234 err = mkTcErr loc ctxt_msgs err_msg
236 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
239 errs_var = getTcErrs down
240 ctxt = getErrCtxt down
243 warnTc :: Bool -> Message -> NF_TcM s ()
244 warnTc warn_if_true warn down env
245 = if warn_if_true then
246 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
247 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
252 errs_var = getTcErrs down
254 recoverTc :: TcM s r -> TcM s r -> TcM s r
255 recoverTc recover m down env
256 = recoverFSST (\ _ -> recover down env) (m down env)
258 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
259 recoverNF_Tc recover m down env
260 = recoverSST (\ _ -> recover down env) (m down env)
262 -- (tryTc r m) tries m; if it succeeds it returns it,
263 -- otherwise it returns r. Any error messages added by m are discarded,
264 -- whether or not m succeeds.
265 tryTc :: TcM s r -> TcM s r -> TcM s r
266 tryTc recover m down env
267 = recoverFSST (\ _ -> recover down env) $
268 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
269 m (setTcErrs down new_errs_var) env
271 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
272 checkTc True err = returnTc ()
273 checkTc False err = failTc err
275 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
276 checkTcM True err = returnTc ()
277 checkTcM False err = err
279 checkMaybeTc :: Maybe val -> Message -> TcM s val
280 checkMaybeTc (Just val) err = returnTc val
281 checkMaybeTc Nothing err = failTc err
283 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
284 checkMaybeTcM (Just val) err = returnTc val
285 checkMaybeTcM Nothing err = err
291 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
292 tcNewMutVar val down env = newMutVarSST val
294 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
295 tcWriteMutVar var val down env = writeMutVarSST var val
297 tcReadMutVar :: MutableVar s a -> NF_TcM s a
298 tcReadMutVar var down env = readMutVarSST var
305 tcGetEnv :: NF_TcM s (TcEnv s)
306 tcGetEnv down env = returnSST env
308 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
309 tcSetEnv new_env m down old_env = m down new_env
316 tcGetDefaultTys :: NF_TcM s [Type]
317 tcGetDefaultTys down env = returnSST (getDefaultTys down)
319 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
320 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
322 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
323 tcAddSrcLoc loc m down env = m (setLoc down loc) env
325 tcGetSrcLoc :: NF_TcM s SrcLoc
326 tcGetSrcLoc down env = returnSST (getLoc down)
328 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
329 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
330 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
332 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
333 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
334 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
341 tcGetUnique :: NF_TcM s Unique
343 = readMutVarSST u_var `thenSST` \ uniq_supply ->
345 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
346 uniq = getUnique uniq_s
348 writeMutVarSST u_var new_uniq_supply `thenSST_`
351 u_var = getUniqSupplyVar down
353 tcGetUniques :: Int -> NF_TcM s [Unique]
354 tcGetUniques n down env
355 = readMutVarSST u_var `thenSST` \ uniq_supply ->
357 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
358 uniqs = getUniques n uniq_s
360 writeMutVarSST u_var new_uniq_supply `thenSST_`
363 u_var = getUniqSupplyVar down
373 [Type] -- Types used for defaulting
375 (MutableVar s UniqSupply) -- Unique supply
377 SrcLoc -- Source location
378 (ErrCtxt s) -- Error context
379 (MutableVar s (Bag TcWarning,
382 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
383 -- to deal with bound type variables just before error
384 -- message construction
387 -- These selectors are *local* to TcMonad.lhs
390 getTcErrs (TcDown def us loc ctxt errs) = errs
391 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
393 getDefaultTys (TcDown def us loc ctxt errs) = def
394 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
396 getLoc (TcDown def us loc ctxt errs) = loc
397 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
399 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
401 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
402 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
403 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
406 @forkTcDown@ makes a new "down" blob for a lazily-computed fork
410 forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
411 = -- Get a fresh unique supply
412 readMutVarSST u_var `thenSST` \ us ->
414 (us1, us2) = splitUniqSupply us
416 writeMutVarSST u_var us1 `thenSST_`
418 -- Make fresh MutVars for the unique supply and errors
419 newMutVarSST us2 `thenSST` \ u_var' ->
420 newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
423 returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
431 rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
433 rn4MtoTcM name_funs rn_action down env
434 = readMutVarSST u_var `thenSST` \ uniq_supply ->
436 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
438 writeMutVarSST u_var new_uniq_supply `thenSST_`
441 = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
443 returnSST (rn_result, rn_errs)
445 u_var = getUniqSupplyVar down
453 type Message = PprStyle -> Pretty
454 type TcError = Message
455 type TcWarning = Message
458 mkTcErr :: SrcLoc -- Where
459 -> [Message] -- Context
460 -> Message -- What went wrong
461 -> TcError -- The complete error report
463 mkTcErr locn ctxt msg sty
464 = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
465 4 (ppAboves [msg sty | msg <- ctxt])
468 arityErr kind name n m sty
469 = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
470 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
472 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
473 quantity | m < n = "few"
475 n_arguments | n == 0 = ppStr "no arguments"
476 | n == 1 = ppStr "1 argument"
477 | True = ppCat [ppInt n, ppStr "arguments"]