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) )
52 import CmdLineOpts ( opt_PprStyle_All )
55 import Bag ( Bag, emptyBag, isEmptyBag,
56 foldBag, unitBag, unionBags, snocBag )
57 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
58 import Maybes ( MaybeErr(..) )
59 import SrcLoc ( SrcLoc, noSrcLoc )
60 import UniqFM ( UniqFM, emptyUFM )
61 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
62 SYN_IE(UniqSM), initUs )
63 import Unique ( Unique )
66 import PprStyle ( PprStyle(..) )
68 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
72 \section{TcM, NF_TcM: the type checker monads}
73 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
76 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
77 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
81 #if __GLASGOW_HASKELL__ >= 200
82 # define REAL_WORLD RealWorld
84 # define REAL_WORLD _RealWorld
87 -- With a builtin polymorphic type for runSST the type for
88 -- initTc should use TcM s r instead of TcM RealWorld r
92 -> MaybeErr (r, Bag Warning)
93 (Bag Error, Bag Warning)
97 newMutVarSST us `thenSST` \ us_var ->
98 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
99 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
101 init_down = TcDown [] us_var
104 init_env = initEnv tvs_var
107 (\_ -> returnSST Nothing)
108 (do_this init_down init_env `thenFSST` \ res ->
109 returnFSST (Just res))
110 `thenSST` \ maybe_res ->
111 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
112 case (maybe_res, isEmptyBag errs) of
113 (Just res, True) -> returnSST (Succeeded (res, warns))
114 _ -> returnSST (Failed (errs, warns))
117 thenNF_Tc :: NF_TcM s a
118 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
119 -> TcDown s -> TcEnv s -> State# s -> b
120 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
121 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
123 thenNF_Tc m k down env
124 = m down env `thenSST` \ r ->
127 thenNF_Tc_ :: NF_TcM s a
128 -> (TcDown s -> TcEnv s -> State# s -> b)
129 -> TcDown s -> TcEnv s -> State# s -> b
130 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
131 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
133 thenNF_Tc_ m k down env
134 = m down env `thenSST_` k down env
136 returnNF_Tc :: a -> NF_TcM s a
137 returnNF_Tc v down env = returnSST v
139 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
140 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
142 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
143 mapNF_Tc f [] = returnNF_Tc []
144 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
145 mapNF_Tc f xs `thenNF_Tc` \ rs ->
148 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
149 listNF_Tc [] = returnNF_Tc []
150 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
151 listNF_Tc xs `thenNF_Tc` \ rs ->
154 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
156 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
157 b2 `thenNF_Tc` \ r2 ->
158 returnNF_Tc (unionBags r1 r2))
159 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
160 (returnNF_Tc emptyBag)
163 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
164 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
165 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
166 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
167 returnNF_Tc (r1:rs1, r2:rs2)
169 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
171 = m down env `thenFSST` \ r ->
174 thenTc_ :: TcM s a -> TcM s b -> TcM s b
176 = m down env `thenFSST_` k down env
178 returnTc :: a -> TcM s a
179 returnTc val down env = returnFSST val
181 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
182 mapTc f [] = returnTc []
183 mapTc f (x:xs) = f x `thenTc` \ r ->
184 mapTc f xs `thenTc` \ rs ->
187 listTc :: [TcM s a] -> TcM s [a]
188 listTc [] = returnTc []
189 listTc (x:xs) = x `thenTc` \ r ->
190 listTc xs `thenTc` \ rs ->
193 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
194 foldrTc k z [] = returnTc z
195 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
198 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
199 foldlTc k z [] = returnTc z
200 foldlTc k z (x:xs) = k z x `thenTc` \r ->
203 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
204 mapAndUnzipTc f [] = returnTc ([],[])
205 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
206 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
207 returnTc (r1:rs1, r2:rs2)
209 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
210 mapAndUnzip3Tc f [] = returnTc ([],[],[])
211 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
212 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
213 returnTc (r1:rs1, r2:rs2, r3:rs3)
215 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
217 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
219 returnTc (unionBags r1 r2))
220 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
224 fixTc :: (a -> TcM s a) -> TcM s a
225 fixTc m env down = fixFSST (\ loop -> m loop env down)
228 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
229 thread. Ideally, this elegantly ensures that it can't zap any type
230 variables that belong to the main thread. But alas, the environment
231 contains TyCon and Class environments that include (TcKind s) stuff,
232 which is a Royal Pain. By the time this fork stuff is used they'll
233 have been unified down so there won't be any kind variables, but we
234 can't express that in the current typechecker framework.
236 So we compromise and use unsafeInterleaveSST.
238 We throw away any error messages!
241 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
242 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
243 = -- Get a fresh unique supply
244 readMutVarSST u_var `thenSST` \ us ->
246 (us1, us2) = splitUniqSupply us
248 writeMutVarSST u_var us1 `thenSST_`
250 unsafeInterleaveSST (
251 newMutVarSST us2 `thenSST` \ us_var' ->
252 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
253 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
255 down' = TcDown deflts us_var' src_loc err_cxt err_var'
258 -- ToDo: optionally dump any error messages
266 getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
268 = readMutVarSST errs_var
270 errs_var = getTcErrs down
272 failTc :: Message -> TcM s a
273 failTc err_msg down env
274 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
275 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
277 err = mkTcErr loc ctxt_msgs err_msg
279 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
282 errs_var = getTcErrs down
283 ctxt = getErrCtxt down
286 warnTc :: Bool -> Message -> NF_TcM s ()
287 warnTc warn_if_true warn down env
288 = if warn_if_true then
289 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
290 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
295 errs_var = getTcErrs down
297 recoverTc :: TcM s r -> TcM s r -> TcM s r
298 recoverTc recover m down env
299 = recoverFSST (\ _ -> recover down env) (m down env)
301 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
302 recoverNF_Tc recover m down env
303 = recoverSST (\ _ -> recover down env) (m down env)
305 -- (tryTc r m) tries m; if it succeeds it returns it,
306 -- otherwise it returns r. Any error messages added by m are discarded,
307 -- whether or not m succeeds.
308 tryTc :: TcM s r -> TcM s r -> TcM s r
309 tryTc recover m down env
310 = recoverFSST (\ _ -> recover down env) $
312 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
314 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
316 -- Check that m has no errors; if it has internal recovery
317 -- mechanisms it might "succeed" but having found a bunch of
318 -- errors along the way. If so we want tryTc to use
320 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
321 if isEmptyBag errs then
326 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
327 checkTc True err = returnTc ()
328 checkTc False err = failTc err
330 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
331 checkTcM True err = returnTc ()
332 checkTcM False err = err
334 checkMaybeTc :: Maybe val -> Message -> TcM s val
335 checkMaybeTc (Just val) err = returnTc val
336 checkMaybeTc Nothing err = failTc err
338 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
339 checkMaybeTcM (Just val) err = returnTc val
340 checkMaybeTcM Nothing err = err
346 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
347 tcNewMutVar val down env = newMutVarSST val
349 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
350 tcWriteMutVar var val down env = writeMutVarSST var val
352 tcReadMutVar :: MutableVar s a -> NF_TcM s a
353 tcReadMutVar var down env = readMutVarSST var
360 tcGetEnv :: NF_TcM s (TcEnv s)
361 tcGetEnv down env = returnSST env
363 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
364 tcSetEnv new_env m down old_env = m down new_env
371 tcGetDefaultTys :: NF_TcM s [Type]
372 tcGetDefaultTys down env = returnSST (getDefaultTys down)
374 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
375 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
377 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
378 tcAddSrcLoc loc m down env = m (setLoc down loc) env
380 tcGetSrcLoc :: NF_TcM s SrcLoc
381 tcGetSrcLoc down env = returnSST (getLoc down)
383 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
384 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
385 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
387 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
388 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
389 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
396 tcGetUnique :: NF_TcM s Unique
398 = readMutVarSST u_var `thenSST` \ uniq_supply ->
400 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
401 uniq = getUnique uniq_s
403 writeMutVarSST u_var new_uniq_supply `thenSST_`
406 u_var = getUniqSupplyVar down
408 tcGetUniques :: Int -> NF_TcM s [Unique]
409 tcGetUniques n down env
410 = readMutVarSST u_var `thenSST` \ uniq_supply ->
412 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
413 uniqs = getUniques n uniq_s
415 writeMutVarSST u_var new_uniq_supply `thenSST_`
418 u_var = getUniqSupplyVar down
420 uniqSMToTcM :: UniqSM a -> NF_TcM s a
421 uniqSMToTcM m down env
422 = readMutVarSST u_var `thenSST` \ uniq_supply ->
424 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
426 writeMutVarSST u_var new_uniq_supply `thenSST_`
427 returnSST (initUs uniq_s m)
429 u_var = getUniqSupplyVar down
439 [Type] -- Types used for defaulting
441 (MutableVar s UniqSupply) -- Unique supply
443 SrcLoc -- Source location
444 (ErrCtxt s) -- Error context
445 (MutableVar s (Bag Warning,
448 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
449 -- to deal with bound type variables just before error
450 -- message construction
453 -- These selectors are *local* to TcMonad.lhs
456 getTcErrs (TcDown def us loc ctxt errs) = errs
457 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
459 getDefaultTys (TcDown def us loc ctxt errs) = def
460 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
462 getLoc (TcDown def us loc ctxt errs) = loc
463 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
465 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
467 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
468 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
469 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
479 type TcError = Message
480 type TcWarning = Message
482 mkTcErr :: SrcLoc -- Where
483 -> [Message] -- Context
484 -> Message -- What went wrong
485 -> TcError -- The complete error report
487 mkTcErr locn ctxt msg sty
488 = ppHang (ppBesides [ppr PprForUser locn, ppPStr SLIT(": "), msg sty])
489 4 (ppAboves [msg sty | msg <- ctxt_to_use])
492 if opt_PprStyle_All then
497 takeAtMost :: Int -> [a] -> [a]
500 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
502 arityErr kind name n m sty
503 = ppBesides [ ppChar '`', ppr sty name, ppPStr SLIT("' should have "),
504 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
506 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
507 quantity | m < n = "few"
509 n_arguments | n == 0 = ppPStr SLIT("no arguments")
510 | n == 1 = ppPStr SLIT("1 argument")
511 | True = ppCat [ppInt n, ppPStr SLIT("arguments")]