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,
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 SYN_IE(TcError), SYN_IE(TcWarning),
36 #if __GLASGOW_HASKELL__ >= 200
45 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
47 import Type ( SYN_IE(Type), GenType )
48 import TyVar ( SYN_IE(TyVar), GenTyVar )
49 import Usage ( SYN_IE(Usage), GenUsage )
50 import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
53 import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn,
54 returnRn, thenRn, getImplicitUpRn
56 import RnUtils ( SYN_IE(RnEnv) )
58 import Bag ( Bag, emptyBag, isEmptyBag,
59 foldBag, unitBag, unionBags, snocBag )
60 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
61 --import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
62 import Maybes ( MaybeErr(..) )
63 --import Name ( Name )
64 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
65 import UniqFM ( UniqFM, emptyUFM )
66 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
67 import Unique ( Unique )
70 import PprStyle ( PprStyle(..) )
72 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
76 \section{TcM, NF_TcM: the type checker monads}
77 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
80 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
81 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
85 #if __GLASGOW_HASKELL__ >= 200
86 # define REAL_WORLD RealWorld
88 # define REAL_WORLD _RealWorld
91 -- With a builtin polymorphic type for runSST the type for
92 -- initTc should use TcM s r instead of TcM RealWorld r
96 -> MaybeErr (r, Bag Warning)
97 (Bag Error, Bag Warning)
101 newMutVarSST us `thenSST` \ us_var ->
102 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
103 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
105 init_down = TcDown [] us_var
108 init_env = initEnv tvs_var
111 (\_ -> returnSST Nothing)
112 (do_this init_down init_env `thenFSST` \ res ->
113 returnFSST (Just res))
114 `thenSST` \ maybe_res ->
115 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
116 case (maybe_res, isEmptyBag errs) of
117 (Just res, True) -> returnSST (Succeeded (res, warns))
118 _ -> returnSST (Failed (errs, warns))
121 thenNF_Tc :: NF_TcM s a
122 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
123 -> TcDown s -> TcEnv s -> State# s -> b
124 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
125 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
127 thenNF_Tc m k down env
128 = m down env `thenSST` \ r ->
131 thenNF_Tc_ :: NF_TcM s a
132 -> (TcDown s -> TcEnv s -> State# s -> b)
133 -> TcDown s -> TcEnv s -> State# s -> b
134 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
135 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
137 thenNF_Tc_ m k down env
138 = m down env `thenSST_` k down env
140 returnNF_Tc :: a -> NF_TcM s a
141 returnNF_Tc v down env = returnSST v
143 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
144 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
146 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
147 mapNF_Tc f [] = returnNF_Tc []
148 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
149 mapNF_Tc f xs `thenNF_Tc` \ rs ->
152 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
153 listNF_Tc [] = returnNF_Tc []
154 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
155 listNF_Tc xs `thenNF_Tc` \ rs ->
158 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
160 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
161 b2 `thenNF_Tc` \ r2 ->
162 returnNF_Tc (unionBags r1 r2))
163 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
164 (returnNF_Tc emptyBag)
167 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
168 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
169 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
170 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
171 returnNF_Tc (r1:rs1, r2:rs2)
173 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
175 = m down env `thenFSST` \ r ->
178 thenTc_ :: TcM s a -> TcM s b -> TcM s b
180 = m down env `thenFSST_` k down env
182 returnTc :: a -> TcM s a
183 returnTc val down env = returnFSST val
185 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
186 mapTc f [] = returnTc []
187 mapTc f (x:xs) = f x `thenTc` \ r ->
188 mapTc f xs `thenTc` \ rs ->
191 listTc :: [TcM s a] -> TcM s [a]
192 listTc [] = returnTc []
193 listTc (x:xs) = x `thenTc` \ r ->
194 listTc xs `thenTc` \ rs ->
197 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
198 foldrTc k z [] = returnTc z
199 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
202 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
203 foldlTc k z [] = returnTc z
204 foldlTc k z (x:xs) = k z x `thenTc` \r ->
207 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
208 mapAndUnzipTc f [] = returnTc ([],[])
209 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
210 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
211 returnTc (r1:rs1, r2:rs2)
213 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
214 mapAndUnzip3Tc f [] = returnTc ([],[],[])
215 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
216 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
217 returnTc (r1:rs1, r2:rs2, r3:rs3)
219 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
221 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
223 returnTc (unionBags r1 r2))
224 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
228 fixTc :: (a -> TcM s a) -> TcM s a
229 fixTc m env down = fixFSST (\ loop -> m loop env down)
232 @forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
233 This elegantly ensures that it can't zap any type variables that
234 belong to the main thread. We throw away any error messages!
237 forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
238 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
239 = -- Get a fresh unique supply
240 readMutVarSST u_var `thenSST` \ us ->
242 (us1, us2) = splitUniqSupply us
244 writeMutVarSST u_var us1 `thenSST_`
246 newMutVarSST us2 `thenSST` \ u_var' ->
247 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
248 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
250 down' = TcDown deflts us_var src_loc err_cxt err_var'
251 env' = forkEnv env tv_var'
255 -- ToDo: optionally dump any error messages
259 @forkTcDown@ makes a new "down" blob for a lazily-computed fork
263 forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
264 = -- Get a fresh unique supply
265 readMutVarSST u_var `thenSST` \ us ->
267 (us1, us2) = splitUniqSupply us
269 writeMutVarSST u_var us1 `thenSST_`
271 -- Make fresh MutVars for the unique supply and errors
272 newMutVarSST us2 `thenSST` \ u_var' ->
273 newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
276 returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
283 failTc :: Message -> TcM s a
284 failTc err_msg down env
285 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
286 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
288 err = mkTcErr loc ctxt_msgs err_msg
290 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
293 errs_var = getTcErrs down
294 ctxt = getErrCtxt down
297 warnTc :: Bool -> Message -> NF_TcM s ()
298 warnTc warn_if_true warn down env
299 = if warn_if_true then
300 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
301 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
306 errs_var = getTcErrs down
308 recoverTc :: TcM s r -> TcM s r -> TcM s r
309 recoverTc recover m down env
310 = recoverFSST (\ _ -> recover down env) (m down env)
312 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
313 recoverNF_Tc recover m down env
314 = recoverSST (\ _ -> recover down env) (m down env)
316 -- (tryTc r m) tries m; if it succeeds it returns it,
317 -- otherwise it returns r. Any error messages added by m are discarded,
318 -- whether or not m succeeds.
319 tryTc :: TcM s r -> TcM s r -> TcM s r
320 tryTc recover m down env
321 = recoverFSST (\ _ -> recover down env) $
323 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
325 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
327 -- Check that m has no errors; if it has internal recovery
328 -- mechanisms it might "succeed" but having found a bunch of
329 -- errors along the way. If so we want tryTc to use
331 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
332 if isEmptyBag errs then
337 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
338 checkTc True err = returnTc ()
339 checkTc False err = failTc err
341 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
342 checkTcM True err = returnTc ()
343 checkTcM False err = err
345 checkMaybeTc :: Maybe val -> Message -> TcM s val
346 checkMaybeTc (Just val) err = returnTc val
347 checkMaybeTc Nothing err = failTc err
349 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
350 checkMaybeTcM (Just val) err = returnTc val
351 checkMaybeTcM Nothing err = err
357 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
358 tcNewMutVar val down env = newMutVarSST val
360 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
361 tcWriteMutVar var val down env = writeMutVarSST var val
363 tcReadMutVar :: MutableVar s a -> NF_TcM s a
364 tcReadMutVar var down env = readMutVarSST var
371 tcGetEnv :: NF_TcM s (TcEnv s)
372 tcGetEnv down env = returnSST env
374 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
375 tcSetEnv new_env m down old_env = m down new_env
382 tcGetDefaultTys :: NF_TcM s [Type]
383 tcGetDefaultTys down env = returnSST (getDefaultTys down)
385 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
386 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
388 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
389 tcAddSrcLoc loc m down env = m (setLoc down loc) env
391 tcGetSrcLoc :: NF_TcM s SrcLoc
392 tcGetSrcLoc down env = returnSST (getLoc down)
394 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
395 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
396 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
398 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
399 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
400 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
407 tcGetUnique :: NF_TcM s Unique
409 = readMutVarSST u_var `thenSST` \ uniq_supply ->
411 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
412 uniq = getUnique uniq_s
414 writeMutVarSST u_var new_uniq_supply `thenSST_`
417 u_var = getUniqSupplyVar down
419 tcGetUniques :: Int -> NF_TcM s [Unique]
420 tcGetUniques n down env
421 = readMutVarSST u_var `thenSST` \ uniq_supply ->
423 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
424 uniqs = getUniques n uniq_s
426 writeMutVarSST u_var new_uniq_supply `thenSST_`
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
477 rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
479 rnMtoTcM rn_env rn_action down env
480 = readMutVarSST u_var `thenSST` \ uniq_supply ->
482 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
484 writeMutVarSST u_var new_uniq_supply `thenSST_`
486 (rn_result, rn_errs, rn_warns)
487 = initRn False{-*interface* mode! so we can see the builtins-}
488 (panic "rnMtoTcM:module")
490 rn_action `thenRn` \ result ->
492 -- Though we are in "interface mode", we must
493 -- not have added anything to the ImplicitEnv!
494 getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
495 if (isEmptyFM v_env && isEmptyFM tc_env)
497 else panic "rnMtoTcM: non-empty ImplicitEnv!"
498 -- (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env]
499 -- ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env]))
502 returnSST (rn_result, rn_errs)
504 u_var = getUniqSupplyVar down
512 type TcError = Message
513 type TcWarning = Message
515 mkTcErr :: SrcLoc -- Where
516 -> [Message] -- Context
517 -> Message -- What went wrong
518 -> TcError -- The complete error report
520 mkTcErr locn ctxt msg sty
521 = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
522 4 (ppAboves [msg sty | msg <- ctxt])
525 arityErr kind name n m sty
526 = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
527 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
529 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
530 quantity | m < n = "few"
532 n_arguments | n == 0 = ppStr "no arguments"
533 | n == 1 = ppStr "1 argument"
534 | True = ppCat [ppInt n, ppStr "arguments"]