2 #include "HsVersions.h"
5 SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
9 returnTc, thenTc, thenTc_, mapTc, listTc,
10 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
11 mapBagTc, fixTc, tryTc, getErrsTc,
15 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
17 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
19 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
20 failTc, warnTc, recoverTc, recoverNF_Tc,
23 tcGetDefaultTys, tcSetDefaultTys,
24 tcGetUnique, tcGetUniques,
26 tcAddSrcLoc, tcGetSrcLoc,
27 tcAddErrCtxtM, tcSetErrCtxtM,
28 tcAddErrCtxt, tcSetErrCtxt,
30 tcNewMutVar, tcReadMutVar, tcWriteMutVar,
32 SYN_IE(TcError), SYN_IE(TcWarning),
37 #if __GLASGOW_HASKELL__ >= 200
46 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
48 import Type ( SYN_IE(Type), GenType )
49 import TyVar ( SYN_IE(TyVar), GenTyVar )
50 import Usage ( SYN_IE(Usage), GenUsage )
51 import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
54 import Bag ( Bag, emptyBag, isEmptyBag,
55 foldBag, unitBag, unionBags, snocBag )
56 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
57 import Maybes ( MaybeErr(..) )
58 import SrcLoc ( SrcLoc, noSrcLoc )
59 import UniqFM ( UniqFM, emptyUFM )
60 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
61 SYN_IE(UniqSM), initUs )
62 import Unique ( Unique )
65 import PprStyle ( PprStyle(..) )
67 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
71 \section{TcM, NF_TcM: the type checker monads}
72 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
75 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
76 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
80 #if __GLASGOW_HASKELL__ >= 200
81 # define REAL_WORLD RealWorld
83 # define REAL_WORLD _RealWorld
86 -- With a builtin polymorphic type for runSST the type for
87 -- initTc should use TcM s r instead of TcM RealWorld r
91 -> MaybeErr (r, Bag Warning)
92 (Bag Error, Bag Warning)
96 newMutVarSST us `thenSST` \ us_var ->
97 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
98 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
100 init_down = TcDown [] us_var
103 init_env = initEnv tvs_var
106 (\_ -> returnSST Nothing)
107 (do_this init_down init_env `thenFSST` \ res ->
108 returnFSST (Just res))
109 `thenSST` \ maybe_res ->
110 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
111 case (maybe_res, isEmptyBag errs) of
112 (Just res, True) -> returnSST (Succeeded (res, warns))
113 _ -> returnSST (Failed (errs, warns))
116 thenNF_Tc :: NF_TcM s a
117 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
118 -> TcDown s -> TcEnv s -> State# s -> b
119 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
120 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
122 thenNF_Tc m k down env
123 = m down env `thenSST` \ r ->
126 thenNF_Tc_ :: NF_TcM s a
127 -> (TcDown s -> TcEnv s -> State# s -> b)
128 -> TcDown s -> TcEnv s -> State# s -> b
129 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
130 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
132 thenNF_Tc_ m k down env
133 = m down env `thenSST_` k down env
135 returnNF_Tc :: a -> NF_TcM s a
136 returnNF_Tc v down env = returnSST v
138 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
139 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
141 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
142 mapNF_Tc f [] = returnNF_Tc []
143 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
144 mapNF_Tc f xs `thenNF_Tc` \ rs ->
147 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
148 listNF_Tc [] = returnNF_Tc []
149 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
150 listNF_Tc xs `thenNF_Tc` \ rs ->
153 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
155 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
156 b2 `thenNF_Tc` \ r2 ->
157 returnNF_Tc (unionBags r1 r2))
158 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
159 (returnNF_Tc emptyBag)
162 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
163 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
164 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
165 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
166 returnNF_Tc (r1:rs1, r2:rs2)
168 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
170 = m down env `thenFSST` \ r ->
173 thenTc_ :: TcM s a -> TcM s b -> TcM s b
175 = m down env `thenFSST_` k down env
177 returnTc :: a -> TcM s a
178 returnTc val down env = returnFSST val
180 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
181 mapTc f [] = returnTc []
182 mapTc f (x:xs) = f x `thenTc` \ r ->
183 mapTc f xs `thenTc` \ rs ->
186 listTc :: [TcM s a] -> TcM s [a]
187 listTc [] = returnTc []
188 listTc (x:xs) = x `thenTc` \ r ->
189 listTc xs `thenTc` \ rs ->
192 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
193 foldrTc k z [] = returnTc z
194 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
197 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
198 foldlTc k z [] = returnTc z
199 foldlTc k z (x:xs) = k z x `thenTc` \r ->
202 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
203 mapAndUnzipTc f [] = returnTc ([],[])
204 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
205 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
206 returnTc (r1:rs1, r2:rs2)
208 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
209 mapAndUnzip3Tc f [] = returnTc ([],[],[])
210 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
211 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
212 returnTc (r1:rs1, r2:rs2, r3:rs3)
214 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
216 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
218 returnTc (unionBags r1 r2))
219 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
223 fixTc :: (a -> TcM s a) -> TcM s a
224 fixTc m env down = fixFSST (\ loop -> m loop env down)
227 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
228 thread. Ideally, this elegantly ensures that it can't zap any type
229 variables that belong to the main thread. But alas, the environment
230 contains TyCon and Class environments that include (TcKind s) stuff,
231 which is a Royal Pain. By the time this fork stuff is used they'll
232 have been unified down so there won't be any kind variables, but we
233 can't express that in the current typechecker framework.
235 So we compromise and use unsafeInterleaveSST.
237 We throw away any error messages!
240 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
241 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
242 = -- Get a fresh unique supply
243 readMutVarSST u_var `thenSST` \ us ->
245 (us1, us2) = splitUniqSupply us
247 writeMutVarSST u_var us1 `thenSST_`
249 unsafeInterleaveSST (
250 newMutVarSST us2 `thenSST` \ us_var' ->
251 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
252 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
254 down' = TcDown deflts us_var' src_loc err_cxt err_var'
257 -- ToDo: optionally dump any error messages
265 getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
267 = readMutVarSST errs_var
269 errs_var = getTcErrs down
271 failTc :: Message -> TcM s a
272 failTc err_msg down env
273 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
274 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
276 err = mkTcErr loc ctxt_msgs err_msg
278 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
281 errs_var = getTcErrs down
282 ctxt = getErrCtxt down
285 warnTc :: Bool -> Message -> NF_TcM s ()
286 warnTc warn_if_true warn down env
287 = if warn_if_true then
288 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
289 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
294 errs_var = getTcErrs down
296 recoverTc :: TcM s r -> TcM s r -> TcM s r
297 recoverTc recover m down env
298 = recoverFSST (\ _ -> recover down env) (m down env)
300 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
301 recoverNF_Tc recover m down env
302 = recoverSST (\ _ -> recover down env) (m down env)
304 -- (tryTc r m) tries m; if it succeeds it returns it,
305 -- otherwise it returns r. Any error messages added by m are discarded,
306 -- whether or not m succeeds.
307 tryTc :: TcM s r -> TcM s r -> TcM s r
308 tryTc recover m down env
309 = recoverFSST (\ _ -> recover down env) $
311 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
313 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
315 -- Check that m has no errors; if it has internal recovery
316 -- mechanisms it might "succeed" but having found a bunch of
317 -- errors along the way. If so we want tryTc to use
319 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
320 if isEmptyBag errs then
325 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
326 checkTc True err = returnTc ()
327 checkTc False err = failTc err
329 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
330 checkTcM True err = returnTc ()
331 checkTcM False err = err
333 checkMaybeTc :: Maybe val -> Message -> TcM s val
334 checkMaybeTc (Just val) err = returnTc val
335 checkMaybeTc Nothing err = failTc err
337 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
338 checkMaybeTcM (Just val) err = returnTc val
339 checkMaybeTcM Nothing err = err
345 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
346 tcNewMutVar val down env = newMutVarSST val
348 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
349 tcWriteMutVar var val down env = writeMutVarSST var val
351 tcReadMutVar :: MutableVar s a -> NF_TcM s a
352 tcReadMutVar var down env = readMutVarSST var
359 tcGetEnv :: NF_TcM s (TcEnv s)
360 tcGetEnv down env = returnSST env
362 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
363 tcSetEnv new_env m down old_env = m down new_env
370 tcGetDefaultTys :: NF_TcM s [Type]
371 tcGetDefaultTys down env = returnSST (getDefaultTys down)
373 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
374 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
376 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
377 tcAddSrcLoc loc m down env = m (setLoc down loc) env
379 tcGetSrcLoc :: NF_TcM s SrcLoc
380 tcGetSrcLoc down env = returnSST (getLoc down)
382 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
383 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
384 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
386 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
387 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
388 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
395 tcGetUnique :: NF_TcM s Unique
397 = readMutVarSST u_var `thenSST` \ uniq_supply ->
399 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
400 uniq = getUnique uniq_s
402 writeMutVarSST u_var new_uniq_supply `thenSST_`
405 u_var = getUniqSupplyVar down
407 tcGetUniques :: Int -> NF_TcM s [Unique]
408 tcGetUniques n down env
409 = readMutVarSST u_var `thenSST` \ uniq_supply ->
411 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
412 uniqs = getUniques n uniq_s
414 writeMutVarSST u_var new_uniq_supply `thenSST_`
417 u_var = getUniqSupplyVar down
419 uniqSMToTcM :: UniqSM a -> NF_TcM s a
420 uniqSMToTcM m down env
421 = readMutVarSST u_var `thenSST` \ uniq_supply ->
423 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
425 writeMutVarSST u_var new_uniq_supply `thenSST_`
426 returnSST (initUs uniq_s m)
428 u_var = getUniqSupplyVar down
438 [Type] -- Types used for defaulting
440 (MutableVar s UniqSupply) -- Unique supply
442 SrcLoc -- Source location
443 (ErrCtxt s) -- Error context
444 (MutableVar s (Bag Warning,
447 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
448 -- to deal with bound type variables just before error
449 -- message construction
452 -- These selectors are *local* to TcMonad.lhs
455 getTcErrs (TcDown def us loc ctxt errs) = errs
456 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
458 getDefaultTys (TcDown def us loc ctxt errs) = def
459 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
461 getLoc (TcDown def us loc ctxt errs) = loc
462 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
464 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
466 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
467 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
468 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
478 type TcError = Message
479 type TcWarning = Message
481 mkTcErr :: SrcLoc -- Where
482 -> [Message] -- Context
483 -> Message -- What went wrong
484 -> TcError -- The complete error report
486 mkTcErr locn ctxt msg sty
487 = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
488 4 (ppAboves [msg sty | msg <- ctxt])
491 arityErr kind name n m sty
492 = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
493 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
495 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
496 quantity | m < n = "few"
498 n_arguments | n == 0 = ppStr "no arguments"
499 | n == 1 = ppStr "1 argument"
500 | True = ppCat [ppInt n, ppStr "arguments"]