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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
49 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
51 import {-# SOURCE #-} TcEnv ( TcEnv, initEnv )
52 import {-# SOURCE #-} TcType ( TcMaybe )
55 import Type ( SYN_IE(Type), GenType )
56 import TyVar ( SYN_IE(TyVar), GenTyVar )
57 import Usage ( SYN_IE(Usage), GenUsage )
58 import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
59 import CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength )
62 import Bag ( Bag, emptyBag, isEmptyBag,
63 foldBag, unitBag, unionBags, snocBag )
64 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
65 import Maybes ( MaybeErr(..) )
66 import SrcLoc ( SrcLoc, noSrcLoc )
67 import UniqFM ( UniqFM, emptyUFM )
68 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
69 SYN_IE(UniqSM), initUs )
70 import Unique ( Unique )
73 import Outputable ( PprStyle(..), Outputable(..) )
76 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
80 \section{TcM, NF_TcM: the type checker monads}
81 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
84 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
85 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
89 #if __GLASGOW_HASKELL__ >= 200
90 # define REAL_WORLD RealWorld
92 # define REAL_WORLD _RealWorld
95 -- With a builtin polymorphic type for runSST the type for
96 -- initTc should use TcM s r instead of TcM RealWorld r
100 -> MaybeErr (r, Bag Warning)
101 (Bag Error, Bag Warning)
105 newMutVarSST us `thenSST` \ us_var ->
106 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
107 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
109 init_down = TcDown [] us_var
112 init_env = initEnv tvs_var
115 (\_ -> returnSST Nothing)
116 (do_this init_down init_env `thenFSST` \ res ->
117 returnFSST (Just res))
118 `thenSST` \ maybe_res ->
119 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
120 case (maybe_res, isEmptyBag errs) of
121 (Just res, True) -> returnSST (Succeeded (res, warns))
122 _ -> returnSST (Failed (errs, warns))
125 thenNF_Tc :: NF_TcM s a
126 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
127 -> TcDown s -> TcEnv s -> State# s -> b
128 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
129 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
131 thenNF_Tc m k down env
132 = m down env `thenSST` \ r ->
135 thenNF_Tc_ :: NF_TcM s a
136 -> (TcDown s -> TcEnv s -> State# s -> b)
137 -> TcDown s -> TcEnv s -> State# s -> b
138 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
139 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
141 thenNF_Tc_ m k down env
142 = m down env `thenSST_` k down env
144 returnNF_Tc :: a -> NF_TcM s a
145 returnNF_Tc v down env = returnSST v
147 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
148 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
150 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
151 mapNF_Tc f [] = returnNF_Tc []
152 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
153 mapNF_Tc f xs `thenNF_Tc` \ rs ->
156 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
157 listNF_Tc [] = returnNF_Tc []
158 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
159 listNF_Tc xs `thenNF_Tc` \ rs ->
162 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
164 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
165 b2 `thenNF_Tc` \ r2 ->
166 returnNF_Tc (unionBags r1 r2))
167 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
168 (returnNF_Tc emptyBag)
171 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
172 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
173 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
174 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
175 returnNF_Tc (r1:rs1, r2:rs2)
177 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
179 = m down env `thenFSST` \ r ->
182 thenTc_ :: TcM s a -> TcM s b -> TcM s b
184 = m down env `thenFSST_` k down env
186 returnTc :: a -> TcM s a
187 returnTc val down env = returnFSST val
189 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
190 mapTc f [] = returnTc []
191 mapTc f (x:xs) = f x `thenTc` \ r ->
192 mapTc f xs `thenTc` \ rs ->
195 listTc :: [TcM s a] -> TcM s [a]
196 listTc [] = returnTc []
197 listTc (x:xs) = x `thenTc` \ r ->
198 listTc xs `thenTc` \ rs ->
201 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
202 foldrTc k z [] = returnTc z
203 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
206 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
207 foldlTc k z [] = returnTc z
208 foldlTc k z (x:xs) = k z x `thenTc` \r ->
211 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
212 mapAndUnzipTc f [] = returnTc ([],[])
213 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
214 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
215 returnTc (r1:rs1, r2:rs2)
217 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
218 mapAndUnzip3Tc f [] = returnTc ([],[],[])
219 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
220 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
221 returnTc (r1:rs1, r2:rs2, r3:rs3)
223 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
225 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
227 returnTc (unionBags r1 r2))
228 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
232 fixTc :: (a -> TcM s a) -> TcM s a
233 fixTc m env down = fixFSST (\ loop -> m loop env down)
236 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
237 thread. Ideally, this elegantly ensures that it can't zap any type
238 variables that belong to the main thread. But alas, the environment
239 contains TyCon and Class environments that include (TcKind s) stuff,
240 which is a Royal Pain. By the time this fork stuff is used they'll
241 have been unified down so there won't be any kind variables, but we
242 can't express that in the current typechecker framework.
244 So we compromise and use unsafeInterleaveSST.
246 We throw away any error messages!
249 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
250 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
251 = -- Get a fresh unique supply
252 readMutVarSST u_var `thenSST` \ us ->
254 (us1, us2) = splitUniqSupply us
256 writeMutVarSST u_var us1 `thenSST_`
258 unsafeInterleaveSST (
259 newMutVarSST us2 `thenSST` \ us_var' ->
260 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
261 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
263 down' = TcDown deflts us_var' src_loc err_cxt err_var'
266 -- ToDo: optionally dump any error messages
274 getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
276 = readMutVarSST errs_var
278 errs_var = getTcErrs down
280 failTc :: Message -> TcM s a
281 failTc err_msg down env
282 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
283 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
285 err = mkTcErr loc ctxt_msgs err_msg
287 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
290 errs_var = getTcErrs down
291 ctxt = getErrCtxt down
294 warnTc :: Bool -> Message -> NF_TcM s ()
295 warnTc warn_if_true warn down env
296 = if warn_if_true then
297 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
298 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
303 errs_var = getTcErrs down
305 recoverTc :: TcM s r -> TcM s r -> TcM s r
306 recoverTc recover m down env
307 = recoverFSST (\ _ -> recover down env) (m down env)
309 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
310 recoverNF_Tc recover m down env
311 = recoverSST (\ _ -> recover down env) (m down env)
313 -- (tryTc r m) tries m; if it succeeds it returns it,
314 -- otherwise it returns r. Any error messages added by m are discarded,
315 -- whether or not m succeeds.
316 tryTc :: TcM s r -> TcM s r -> TcM s r
317 tryTc recover m down env
318 = recoverFSST (\ _ -> recover down env) $
320 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
322 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
324 -- Check that m has no errors; if it has internal recovery
325 -- mechanisms it might "succeed" but having found a bunch of
326 -- errors along the way. If so we want tryTc to use
328 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
329 if isEmptyBag errs then
334 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
335 checkTc True err = returnTc ()
336 checkTc False err = failTc err
338 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
339 checkTcM True err = returnTc ()
340 checkTcM False err = err
342 checkMaybeTc :: Maybe val -> Message -> TcM s val
343 checkMaybeTc (Just val) err = returnTc val
344 checkMaybeTc Nothing err = failTc err
346 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
347 checkMaybeTcM (Just val) err = returnTc val
348 checkMaybeTcM Nothing err = err
354 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
355 tcNewMutVar val down env = newMutVarSST val
357 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
358 tcWriteMutVar var val down env = writeMutVarSST var val
360 tcReadMutVar :: MutableVar s a -> NF_TcM s a
361 tcReadMutVar var down env = readMutVarSST var
368 tcGetEnv :: NF_TcM s (TcEnv s)
369 tcGetEnv down env = returnSST env
371 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
372 tcSetEnv new_env m down old_env = m down new_env
379 tcGetDefaultTys :: NF_TcM s [Type]
380 tcGetDefaultTys down env = returnSST (getDefaultTys down)
382 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
383 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
385 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
386 tcAddSrcLoc loc m down env = m (setLoc down loc) env
388 tcGetSrcLoc :: NF_TcM s SrcLoc
389 tcGetSrcLoc down env = returnSST (getLoc down)
391 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
392 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
393 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
395 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
396 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
397 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
404 tcGetUnique :: NF_TcM s Unique
406 = readMutVarSST u_var `thenSST` \ uniq_supply ->
408 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
409 uniq = getUnique uniq_s
411 writeMutVarSST u_var new_uniq_supply `thenSST_`
414 u_var = getUniqSupplyVar down
416 tcGetUniques :: Int -> NF_TcM s [Unique]
417 tcGetUniques n down env
418 = readMutVarSST u_var `thenSST` \ uniq_supply ->
420 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
421 uniqs = getUniques n uniq_s
423 writeMutVarSST u_var new_uniq_supply `thenSST_`
426 u_var = getUniqSupplyVar down
428 uniqSMToTcM :: UniqSM a -> NF_TcM s a
429 uniqSMToTcM m down env
430 = readMutVarSST u_var `thenSST` \ uniq_supply ->
432 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
434 writeMutVarSST u_var new_uniq_supply `thenSST_`
435 returnSST (initUs uniq_s m)
437 u_var = getUniqSupplyVar down
447 [Type] -- Types used for defaulting
449 (MutableVar s UniqSupply) -- Unique supply
451 SrcLoc -- Source location
452 (ErrCtxt s) -- Error context
453 (MutableVar s (Bag Warning,
456 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
457 -- to deal with bound type variables just before error
458 -- message construction
461 -- These selectors are *local* to TcMonad.lhs
464 getTcErrs (TcDown def us loc ctxt errs) = errs
465 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
467 getDefaultTys (TcDown def us loc ctxt errs) = def
468 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
470 getLoc (TcDown def us loc ctxt errs) = loc
471 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
473 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
475 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
476 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
477 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
487 type TcError = Message
488 type TcWarning = Message
490 mkTcErr :: SrcLoc -- Where
491 -> [Message] -- Context
492 -> Message -- What went wrong
493 -> TcError -- The complete error report
495 mkTcErr locn ctxt msg sty
496 = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, ptext SLIT(": "), msg sty])
497 4 (vcat [msg sty | msg <- ctxt_to_use])
500 if opt_PprStyle_All then
505 takeAtMost :: Int -> [a] -> [a]
508 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
510 arityErr kind name n m sty
511 = hsep [ ppr sty name, ptext SLIT("should have"),
512 n_arguments <> comma, text "but has been given", int m, char '.']
514 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
515 quantity | m < n = "few"
517 n_arguments | n == 0 = ptext SLIT("no arguments")
518 | n == 1 = ptext SLIT("1 argument")
519 | True = hsep [int n, ptext SLIT("arguments")]