2 #include "HsVersions.h"
5 TcM(..), NF_TcM(..), TcDown, TcEnv,
9 returnTc, thenTc, thenTc_, mapTc, listTc,
10 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
11 mapBagTc, fixTc, tryTc,
13 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc,
14 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
16 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
17 failTc, warnTc, recoverTc, recoverNF_Tc,
20 tcGetDefaultTys, tcSetDefaultTys,
21 tcGetUnique, tcGetUniques,
23 tcAddSrcLoc, tcGetSrcLoc,
24 tcAddErrCtxtM, tcSetErrCtxtM,
25 tcAddErrCtxt, tcSetErrCtxt,
27 tcNewMutVar, tcReadMutVar, tcWriteMutVar,
31 TcError(..), TcWarning(..),
35 MutableVar(..), _MutableArray
40 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
42 import Type ( SYN_IE(Type), GenType )
43 import TyVar ( SYN_IE(TyVar), GenTyVar )
44 import Usage ( SYN_IE(Usage), GenUsage )
45 import ErrUtils ( SYN_IE(Error), SYN_IE(Message), ErrCtxt(..),
49 import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn,
50 returnRn, thenRn, getImplicitUpRn
52 import RnUtils ( SYN_IE(RnEnv) )
54 import Bag ( Bag, emptyBag, isEmptyBag,
55 foldBag, unitBag, unionBags, snocBag )
56 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, keysFM{-ToDo:rm-} )
57 --import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
58 import ErrUtils ( SYN_IE(Error) )
59 import Maybes ( MaybeErr(..) )
60 --import Name ( Name )
61 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
62 import UniqFM ( UniqFM, emptyUFM )
63 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
64 import Unique ( Unique )
67 import PprStyle ( PprStyle(..) )
69 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
73 \section{TcM, NF_TcM: the type checker monads}
74 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
77 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
78 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
82 -- With a builtin polymorphic type for runSST the type for
83 -- initTc should use TcM s r instead of TcM RealWorld r
87 -> MaybeErr (r, Bag Warning)
88 (Bag Error, Bag Warning)
92 newMutVarSST us `thenSST` \ us_var ->
93 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
94 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
96 init_down = TcDown [] us_var
99 init_env = initEnv tvs_var
102 (\_ -> returnSST Nothing)
103 (do_this init_down init_env `thenFSST` \ res ->
104 returnFSST (Just res))
105 `thenSST` \ maybe_res ->
106 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
107 case (maybe_res, isEmptyBag errs) of
108 (Just res, True) -> returnSST (Succeeded (res, warns))
109 _ -> returnSST (Failed (errs, warns))
112 thenNF_Tc :: NF_TcM s a
113 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
114 -> TcDown s -> TcEnv s -> State# s -> b
115 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
116 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
118 thenNF_Tc m k down env
119 = m down env `thenSST` \ r ->
122 thenNF_Tc_ :: NF_TcM s a
123 -> (TcDown s -> TcEnv s -> State# s -> b)
124 -> TcDown s -> TcEnv s -> State# s -> b
125 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
126 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
128 thenNF_Tc_ m k down env
129 = m down env `thenSST_` k down env
131 returnNF_Tc :: a -> NF_TcM s a
132 returnNF_Tc v down env = returnSST v
134 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
135 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
137 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
138 mapNF_Tc f [] = returnNF_Tc []
139 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
140 mapNF_Tc f xs `thenNF_Tc` \ rs ->
143 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
144 listNF_Tc [] = returnNF_Tc []
145 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
146 listNF_Tc xs `thenNF_Tc` \ rs ->
149 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
151 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
152 b2 `thenNF_Tc` \ r2 ->
153 returnNF_Tc (unionBags r1 r2))
154 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
155 (returnNF_Tc emptyBag)
158 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
159 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
160 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
161 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
162 returnNF_Tc (r1:rs1, r2:rs2)
164 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
166 = m down env `thenFSST` \ r ->
169 thenTc_ :: TcM s a -> TcM s b -> TcM s b
171 = m down env `thenFSST_` k down env
173 returnTc :: a -> TcM s a
174 returnTc val down env = returnFSST val
176 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
177 mapTc f [] = returnTc []
178 mapTc f (x:xs) = f x `thenTc` \ r ->
179 mapTc f xs `thenTc` \ rs ->
182 listTc :: [TcM s a] -> TcM s [a]
183 listTc [] = returnTc []
184 listTc (x:xs) = x `thenTc` \ r ->
185 listTc xs `thenTc` \ rs ->
188 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
189 foldrTc k z [] = returnTc z
190 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
193 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
194 foldlTc k z [] = returnTc z
195 foldlTc k z (x:xs) = k z x `thenTc` \r ->
198 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
199 mapAndUnzipTc f [] = returnTc ([],[])
200 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
201 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
202 returnTc (r1:rs1, r2:rs2)
204 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
205 mapAndUnzip3Tc f [] = returnTc ([],[],[])
206 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
207 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
208 returnTc (r1:rs1, r2:rs2, r3:rs3)
210 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
212 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
214 returnTc (unionBags r1 r2))
215 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
219 fixTc :: (a -> TcM s a) -> TcM s a
220 fixTc m env down = fixFSST (\ loop -> m loop env down)
223 @forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
224 This elegantly ensures that it can't zap any type variables that
225 belong to the main thread. We throw away any error messages!
228 forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
229 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
230 = -- Get a fresh unique supply
231 readMutVarSST u_var `thenSST` \ us ->
233 (us1, us2) = splitUniqSupply us
235 writeMutVarSST u_var us1 `thenSST_`
237 newMutVarSST us2 `thenSST` \ u_var' ->
238 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
239 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
241 down' = TcDown deflts us_var src_loc err_cxt err_var'
242 env' = forkEnv env tv_var'
246 -- ToDo: optionally dump any error messages
250 @forkTcDown@ makes a new "down" blob for a lazily-computed fork
254 forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
255 = -- Get a fresh unique supply
256 readMutVarSST u_var `thenSST` \ us ->
258 (us1, us2) = splitUniqSupply us
260 writeMutVarSST u_var us1 `thenSST_`
262 -- Make fresh MutVars for the unique supply and errors
263 newMutVarSST us2 `thenSST` \ u_var' ->
264 newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
267 returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
274 failTc :: Message -> TcM s a
275 failTc err_msg down env
276 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
277 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
279 err = mkTcErr loc ctxt_msgs err_msg
281 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
284 errs_var = getTcErrs down
285 ctxt = getErrCtxt down
288 warnTc :: Bool -> Message -> NF_TcM s ()
289 warnTc warn_if_true warn down env
290 = if warn_if_true then
291 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
292 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
297 errs_var = getTcErrs down
299 recoverTc :: TcM s r -> TcM s r -> TcM s r
300 recoverTc recover m down env
301 = recoverFSST (\ _ -> recover down env) (m down env)
303 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
304 recoverNF_Tc recover m down env
305 = recoverSST (\ _ -> recover down env) (m down env)
307 -- (tryTc r m) tries m; if it succeeds it returns it,
308 -- otherwise it returns r. Any error messages added by m are discarded,
309 -- whether or not m succeeds.
310 tryTc :: TcM s r -> TcM s r -> TcM s r
311 tryTc recover m down env
312 = recoverFSST (\ _ -> recover down env) $
314 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
316 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
318 -- Check that m has no errors; if it has internal recovery
319 -- mechanisms it might "succeed" but having found a bunch of
320 -- errors along the way. If so we want tryTc to use
322 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
323 if isEmptyBag errs then
328 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
329 checkTc True err = returnTc ()
330 checkTc False err = failTc err
332 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
333 checkTcM True err = returnTc ()
334 checkTcM False err = err
336 checkMaybeTc :: Maybe val -> Message -> TcM s val
337 checkMaybeTc (Just val) err = returnTc val
338 checkMaybeTc Nothing err = failTc err
340 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
341 checkMaybeTcM (Just val) err = returnTc val
342 checkMaybeTcM Nothing err = err
348 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
349 tcNewMutVar val down env = newMutVarSST val
351 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
352 tcWriteMutVar var val down env = writeMutVarSST var val
354 tcReadMutVar :: MutableVar s a -> NF_TcM s a
355 tcReadMutVar var down env = readMutVarSST var
362 tcGetEnv :: NF_TcM s (TcEnv s)
363 tcGetEnv down env = returnSST env
365 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
366 tcSetEnv new_env m down old_env = m down new_env
373 tcGetDefaultTys :: NF_TcM s [Type]
374 tcGetDefaultTys down env = returnSST (getDefaultTys down)
376 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
377 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
379 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
380 tcAddSrcLoc loc m down env = m (setLoc down loc) env
382 tcGetSrcLoc :: NF_TcM s SrcLoc
383 tcGetSrcLoc down env = returnSST (getLoc down)
385 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
386 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
387 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
389 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
390 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
391 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
398 tcGetUnique :: NF_TcM s Unique
400 = readMutVarSST u_var `thenSST` \ uniq_supply ->
402 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
403 uniq = getUnique uniq_s
405 writeMutVarSST u_var new_uniq_supply `thenSST_`
408 u_var = getUniqSupplyVar down
410 tcGetUniques :: Int -> NF_TcM s [Unique]
411 tcGetUniques n down env
412 = readMutVarSST u_var `thenSST` \ uniq_supply ->
414 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
415 uniqs = getUniques n uniq_s
417 writeMutVarSST u_var new_uniq_supply `thenSST_`
420 u_var = getUniqSupplyVar down
430 [Type] -- Types used for defaulting
432 (MutableVar s UniqSupply) -- Unique supply
434 SrcLoc -- Source location
435 (ErrCtxt s) -- Error context
436 (MutableVar s (Bag Warning,
439 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
440 -- to deal with bound type variables just before error
441 -- message construction
444 -- These selectors are *local* to TcMonad.lhs
447 getTcErrs (TcDown def us loc ctxt errs) = errs
448 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
450 getDefaultTys (TcDown def us loc ctxt errs) = def
451 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
453 getLoc (TcDown def us loc ctxt errs) = loc
454 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
456 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
458 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
459 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
460 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
468 rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error)
470 rnMtoTcM rn_env rn_action down env
471 = readMutVarSST u_var `thenSST` \ uniq_supply ->
473 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
475 writeMutVarSST u_var new_uniq_supply `thenSST_`
477 (rn_result, rn_errs, rn_warns)
478 = initRn False{-*interface* mode! so we can see the builtins-}
479 (panic "rnMtoTcM:module")
481 rn_action `thenRn` \ result ->
483 -- Though we are in "interface mode", we must
484 -- not have added anything to the ImplicitEnv!
485 getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
486 if (isEmptyFM v_env && isEmptyFM tc_env)
488 else pprPanic "rnMtoTcM: non-empty ImplicitEnv!"
489 (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
490 ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
493 returnSST (rn_result, rn_errs)
495 u_var = getUniqSupplyVar down
503 type TcError = Message
504 type TcWarning = Message
506 mkTcErr :: SrcLoc -- Where
507 -> [Message] -- Context
508 -> Message -- What went wrong
509 -> TcError -- The complete error report
511 mkTcErr locn ctxt msg sty
512 = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
513 4 (ppAboves [msg sty | msg <- ctxt])
516 arityErr kind name n m sty
517 = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
518 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
520 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
521 quantity | m < n = "few"
523 n_arguments | n == 0 = ppStr "no arguments"
524 | n == 1 = ppStr "1 argument"
525 | True = ppCat [ppInt n, ppStr "arguments"]