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__ == 201
39 #elif __GLASGOW_HASKELL__ == 201
48 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
50 import Type ( SYN_IE(Type), GenType )
51 import TyVar ( SYN_IE(TyVar), GenTyVar )
52 import Usage ( SYN_IE(Usage), GenUsage )
53 import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
54 import CmdLineOpts ( opt_PprStyle_All )
57 import Bag ( Bag, emptyBag, isEmptyBag,
58 foldBag, unitBag, unionBags, snocBag )
59 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
60 import Maybes ( MaybeErr(..) )
61 import SrcLoc ( SrcLoc, noSrcLoc )
62 import UniqFM ( UniqFM, emptyUFM )
63 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
64 SYN_IE(UniqSM), initUs )
65 import Unique ( Unique )
68 import PprStyle ( PprStyle(..) )
69 #if __GLASGOW_HASKELL__ >= 202
73 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
77 \section{TcM, NF_TcM: the type checker monads}
78 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
81 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
82 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
86 #if __GLASGOW_HASKELL__ >= 200
87 # define REAL_WORLD RealWorld
89 # define REAL_WORLD _RealWorld
92 -- With a builtin polymorphic type for runSST the type for
93 -- initTc should use TcM s r instead of TcM RealWorld r
97 -> MaybeErr (r, Bag Warning)
98 (Bag Error, Bag Warning)
102 newMutVarSST us `thenSST` \ us_var ->
103 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
104 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
106 init_down = TcDown [] us_var
109 init_env = initEnv tvs_var
112 (\_ -> returnSST Nothing)
113 (do_this init_down init_env `thenFSST` \ res ->
114 returnFSST (Just res))
115 `thenSST` \ maybe_res ->
116 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
117 case (maybe_res, isEmptyBag errs) of
118 (Just res, True) -> returnSST (Succeeded (res, warns))
119 _ -> returnSST (Failed (errs, warns))
122 thenNF_Tc :: NF_TcM s a
123 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
124 -> TcDown s -> TcEnv s -> State# s -> b
125 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
126 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
128 thenNF_Tc m k down env
129 = m down env `thenSST` \ r ->
132 thenNF_Tc_ :: NF_TcM s a
133 -> (TcDown s -> TcEnv s -> State# s -> b)
134 -> TcDown s -> TcEnv s -> State# s -> b
135 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
136 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
138 thenNF_Tc_ m k down env
139 = m down env `thenSST_` k down env
141 returnNF_Tc :: a -> NF_TcM s a
142 returnNF_Tc v down env = returnSST v
144 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
145 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
147 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
148 mapNF_Tc f [] = returnNF_Tc []
149 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
150 mapNF_Tc f xs `thenNF_Tc` \ rs ->
153 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
154 listNF_Tc [] = returnNF_Tc []
155 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
156 listNF_Tc xs `thenNF_Tc` \ rs ->
159 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
161 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
162 b2 `thenNF_Tc` \ r2 ->
163 returnNF_Tc (unionBags r1 r2))
164 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
165 (returnNF_Tc emptyBag)
168 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
169 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
170 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
171 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
172 returnNF_Tc (r1:rs1, r2:rs2)
174 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
176 = m down env `thenFSST` \ r ->
179 thenTc_ :: TcM s a -> TcM s b -> TcM s b
181 = m down env `thenFSST_` k down env
183 returnTc :: a -> TcM s a
184 returnTc val down env = returnFSST val
186 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
187 mapTc f [] = returnTc []
188 mapTc f (x:xs) = f x `thenTc` \ r ->
189 mapTc f xs `thenTc` \ rs ->
192 listTc :: [TcM s a] -> TcM s [a]
193 listTc [] = returnTc []
194 listTc (x:xs) = x `thenTc` \ r ->
195 listTc xs `thenTc` \ rs ->
198 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
199 foldrTc k z [] = returnTc z
200 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
203 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
204 foldlTc k z [] = returnTc z
205 foldlTc k z (x:xs) = k z x `thenTc` \r ->
208 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
209 mapAndUnzipTc f [] = returnTc ([],[])
210 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
211 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
212 returnTc (r1:rs1, r2:rs2)
214 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
215 mapAndUnzip3Tc f [] = returnTc ([],[],[])
216 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
217 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
218 returnTc (r1:rs1, r2:rs2, r3:rs3)
220 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
222 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
224 returnTc (unionBags r1 r2))
225 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
229 fixTc :: (a -> TcM s a) -> TcM s a
230 fixTc m env down = fixFSST (\ loop -> m loop env down)
233 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
234 thread. Ideally, this elegantly ensures that it can't zap any type
235 variables that belong to the main thread. But alas, the environment
236 contains TyCon and Class environments that include (TcKind s) stuff,
237 which is a Royal Pain. By the time this fork stuff is used they'll
238 have been unified down so there won't be any kind variables, but we
239 can't express that in the current typechecker framework.
241 So we compromise and use unsafeInterleaveSST.
243 We throw away any error messages!
246 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
247 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
248 = -- Get a fresh unique supply
249 readMutVarSST u_var `thenSST` \ us ->
251 (us1, us2) = splitUniqSupply us
253 writeMutVarSST u_var us1 `thenSST_`
255 unsafeInterleaveSST (
256 newMutVarSST us2 `thenSST` \ us_var' ->
257 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
258 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
260 down' = TcDown deflts us_var' src_loc err_cxt err_var'
263 -- ToDo: optionally dump any error messages
271 getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
273 = readMutVarSST errs_var
275 errs_var = getTcErrs down
277 failTc :: Message -> TcM s a
278 failTc err_msg down env
279 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
280 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
282 err = mkTcErr loc ctxt_msgs err_msg
284 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
287 errs_var = getTcErrs down
288 ctxt = getErrCtxt down
291 warnTc :: Bool -> Message -> NF_TcM s ()
292 warnTc warn_if_true warn down env
293 = if warn_if_true then
294 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
295 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
300 errs_var = getTcErrs down
302 recoverTc :: TcM s r -> TcM s r -> TcM s r
303 recoverTc recover m down env
304 = recoverFSST (\ _ -> recover down env) (m down env)
306 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
307 recoverNF_Tc recover m down env
308 = recoverSST (\ _ -> recover down env) (m down env)
310 -- (tryTc r m) tries m; if it succeeds it returns it,
311 -- otherwise it returns r. Any error messages added by m are discarded,
312 -- whether or not m succeeds.
313 tryTc :: TcM s r -> TcM s r -> TcM s r
314 tryTc recover m down env
315 = recoverFSST (\ _ -> recover down env) $
317 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
319 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
321 -- Check that m has no errors; if it has internal recovery
322 -- mechanisms it might "succeed" but having found a bunch of
323 -- errors along the way. If so we want tryTc to use
325 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
326 if isEmptyBag errs then
331 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
332 checkTc True err = returnTc ()
333 checkTc False err = failTc err
335 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
336 checkTcM True err = returnTc ()
337 checkTcM False err = err
339 checkMaybeTc :: Maybe val -> Message -> TcM s val
340 checkMaybeTc (Just val) err = returnTc val
341 checkMaybeTc Nothing err = failTc err
343 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
344 checkMaybeTcM (Just val) err = returnTc val
345 checkMaybeTcM Nothing err = err
351 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
352 tcNewMutVar val down env = newMutVarSST val
354 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
355 tcWriteMutVar var val down env = writeMutVarSST var val
357 tcReadMutVar :: MutableVar s a -> NF_TcM s a
358 tcReadMutVar var down env = readMutVarSST var
365 tcGetEnv :: NF_TcM s (TcEnv s)
366 tcGetEnv down env = returnSST env
368 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
369 tcSetEnv new_env m down old_env = m down new_env
376 tcGetDefaultTys :: NF_TcM s [Type]
377 tcGetDefaultTys down env = returnSST (getDefaultTys down)
379 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
380 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
382 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
383 tcAddSrcLoc loc m down env = m (setLoc down loc) env
385 tcGetSrcLoc :: NF_TcM s SrcLoc
386 tcGetSrcLoc down env = returnSST (getLoc down)
388 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
389 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
390 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
392 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
393 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
394 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
401 tcGetUnique :: NF_TcM s Unique
403 = readMutVarSST u_var `thenSST` \ uniq_supply ->
405 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
406 uniq = getUnique uniq_s
408 writeMutVarSST u_var new_uniq_supply `thenSST_`
411 u_var = getUniqSupplyVar down
413 tcGetUniques :: Int -> NF_TcM s [Unique]
414 tcGetUniques n down env
415 = readMutVarSST u_var `thenSST` \ uniq_supply ->
417 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
418 uniqs = getUniques n uniq_s
420 writeMutVarSST u_var new_uniq_supply `thenSST_`
423 u_var = getUniqSupplyVar down
425 uniqSMToTcM :: UniqSM a -> NF_TcM s a
426 uniqSMToTcM m down env
427 = readMutVarSST u_var `thenSST` \ uniq_supply ->
429 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
431 writeMutVarSST u_var new_uniq_supply `thenSST_`
432 returnSST (initUs uniq_s m)
434 u_var = getUniqSupplyVar down
444 [Type] -- Types used for defaulting
446 (MutableVar s UniqSupply) -- Unique supply
448 SrcLoc -- Source location
449 (ErrCtxt s) -- Error context
450 (MutableVar s (Bag Warning,
453 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
454 -- to deal with bound type variables just before error
455 -- message construction
458 -- These selectors are *local* to TcMonad.lhs
461 getTcErrs (TcDown def us loc ctxt errs) = errs
462 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
464 getDefaultTys (TcDown def us loc ctxt errs) = def
465 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
467 getLoc (TcDown def us loc ctxt errs) = loc
468 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
470 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
472 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
473 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
474 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
484 type TcError = Message
485 type TcWarning = Message
487 mkTcErr :: SrcLoc -- Where
488 -> [Message] -- Context
489 -> Message -- What went wrong
490 -> TcError -- The complete error report
492 mkTcErr locn ctxt msg sty
493 = hang (hcat [ppr PprForUser locn, ptext SLIT(": "), msg sty])
494 4 (vcat [msg sty | msg <- ctxt_to_use])
497 if opt_PprStyle_All then
502 takeAtMost :: Int -> [a] -> [a]
505 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
507 arityErr kind name n m sty
508 = hsep [ ppr sty name, ptext SLIT("should have"),
509 n_arguments <> comma, text "but has been given", int m, char '.']
511 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
512 quantity | m < n = "few"
514 n_arguments | n == 0 = ptext SLIT("no arguments")
515 | n == 1 = ptext SLIT("1 argument")
516 | True = hsep [int n, ptext SLIT("arguments")]