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, opt_PprUserLength )
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 Outputable ( PprStyle(..), Outputable(..) )
71 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
75 \section{TcM, NF_TcM: the type checker monads}
76 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
79 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
80 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
84 #if __GLASGOW_HASKELL__ >= 200
85 # define REAL_WORLD RealWorld
87 # define REAL_WORLD _RealWorld
90 -- With a builtin polymorphic type for runSST the type for
91 -- initTc should use TcM s r instead of TcM RealWorld r
95 -> MaybeErr (r, Bag Warning)
96 (Bag Error, Bag Warning)
100 newMutVarSST us `thenSST` \ us_var ->
101 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
102 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
104 init_down = TcDown [] us_var
107 init_env = initEnv tvs_var
110 (\_ -> returnSST Nothing)
111 (do_this init_down init_env `thenFSST` \ res ->
112 returnFSST (Just res))
113 `thenSST` \ maybe_res ->
114 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
115 case (maybe_res, isEmptyBag errs) of
116 (Just res, True) -> returnSST (Succeeded (res, warns))
117 _ -> returnSST (Failed (errs, warns))
120 thenNF_Tc :: NF_TcM s a
121 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
122 -> TcDown s -> TcEnv s -> State# s -> b
123 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
124 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
126 thenNF_Tc m k down env
127 = m down env `thenSST` \ r ->
130 thenNF_Tc_ :: NF_TcM s a
131 -> (TcDown s -> TcEnv s -> State# s -> b)
132 -> TcDown s -> TcEnv s -> State# s -> b
133 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
134 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
136 thenNF_Tc_ m k down env
137 = m down env `thenSST_` k down env
139 returnNF_Tc :: a -> NF_TcM s a
140 returnNF_Tc v down env = returnSST v
142 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
143 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
145 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
146 mapNF_Tc f [] = returnNF_Tc []
147 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
148 mapNF_Tc f xs `thenNF_Tc` \ rs ->
151 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
152 listNF_Tc [] = returnNF_Tc []
153 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
154 listNF_Tc xs `thenNF_Tc` \ rs ->
157 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
159 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
160 b2 `thenNF_Tc` \ r2 ->
161 returnNF_Tc (unionBags r1 r2))
162 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
163 (returnNF_Tc emptyBag)
166 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
167 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
168 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
169 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
170 returnNF_Tc (r1:rs1, r2:rs2)
172 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
174 = m down env `thenFSST` \ r ->
177 thenTc_ :: TcM s a -> TcM s b -> TcM s b
179 = m down env `thenFSST_` k down env
181 returnTc :: a -> TcM s a
182 returnTc val down env = returnFSST val
184 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
185 mapTc f [] = returnTc []
186 mapTc f (x:xs) = f x `thenTc` \ r ->
187 mapTc f xs `thenTc` \ rs ->
190 listTc :: [TcM s a] -> TcM s [a]
191 listTc [] = returnTc []
192 listTc (x:xs) = x `thenTc` \ r ->
193 listTc xs `thenTc` \ rs ->
196 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
197 foldrTc k z [] = returnTc z
198 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
201 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
202 foldlTc k z [] = returnTc z
203 foldlTc k z (x:xs) = k z x `thenTc` \r ->
206 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
207 mapAndUnzipTc f [] = returnTc ([],[])
208 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
209 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
210 returnTc (r1:rs1, r2:rs2)
212 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
213 mapAndUnzip3Tc f [] = returnTc ([],[],[])
214 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
215 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
216 returnTc (r1:rs1, r2:rs2, r3:rs3)
218 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
220 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
222 returnTc (unionBags r1 r2))
223 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
227 fixTc :: (a -> TcM s a) -> TcM s a
228 fixTc m env down = fixFSST (\ loop -> m loop env down)
231 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
232 thread. Ideally, this elegantly ensures that it can't zap any type
233 variables that belong to the main thread. But alas, the environment
234 contains TyCon and Class environments that include (TcKind s) stuff,
235 which is a Royal Pain. By the time this fork stuff is used they'll
236 have been unified down so there won't be any kind variables, but we
237 can't express that in the current typechecker framework.
239 So we compromise and use unsafeInterleaveSST.
241 We throw away any error messages!
244 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
245 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
246 = -- Get a fresh unique supply
247 readMutVarSST u_var `thenSST` \ us ->
249 (us1, us2) = splitUniqSupply us
251 writeMutVarSST u_var us1 `thenSST_`
253 unsafeInterleaveSST (
254 newMutVarSST us2 `thenSST` \ us_var' ->
255 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
256 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
258 down' = TcDown deflts us_var' src_loc err_cxt err_var'
261 -- ToDo: optionally dump any error messages
269 getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
271 = readMutVarSST errs_var
273 errs_var = getTcErrs down
275 failTc :: Message -> TcM s a
276 failTc err_msg down env
277 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
278 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
280 err = mkTcErr loc ctxt_msgs err_msg
282 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
285 errs_var = getTcErrs down
286 ctxt = getErrCtxt down
289 warnTc :: Bool -> Message -> NF_TcM s ()
290 warnTc warn_if_true warn down env
291 = if warn_if_true then
292 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
293 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
298 errs_var = getTcErrs down
300 recoverTc :: TcM s r -> TcM s r -> TcM s r
301 recoverTc recover m down env
302 = recoverFSST (\ _ -> recover down env) (m down env)
304 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
305 recoverNF_Tc recover m down env
306 = recoverSST (\ _ -> recover down env) (m down env)
308 -- (tryTc r m) tries m; if it succeeds it returns it,
309 -- otherwise it returns r. Any error messages added by m are discarded,
310 -- whether or not m succeeds.
311 tryTc :: TcM s r -> TcM s r -> TcM s r
312 tryTc recover m down env
313 = recoverFSST (\ _ -> recover down env) $
315 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
317 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
319 -- Check that m has no errors; if it has internal recovery
320 -- mechanisms it might "succeed" but having found a bunch of
321 -- errors along the way. If so we want tryTc to use
323 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
324 if isEmptyBag errs then
329 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
330 checkTc True err = returnTc ()
331 checkTc False err = failTc err
333 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
334 checkTcM True err = returnTc ()
335 checkTcM False err = err
337 checkMaybeTc :: Maybe val -> Message -> TcM s val
338 checkMaybeTc (Just val) err = returnTc val
339 checkMaybeTc Nothing err = failTc err
341 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
342 checkMaybeTcM (Just val) err = returnTc val
343 checkMaybeTcM Nothing err = err
349 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
350 tcNewMutVar val down env = newMutVarSST val
352 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
353 tcWriteMutVar var val down env = writeMutVarSST var val
355 tcReadMutVar :: MutableVar s a -> NF_TcM s a
356 tcReadMutVar var down env = readMutVarSST var
363 tcGetEnv :: NF_TcM s (TcEnv s)
364 tcGetEnv down env = returnSST env
366 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
367 tcSetEnv new_env m down old_env = m down new_env
374 tcGetDefaultTys :: NF_TcM s [Type]
375 tcGetDefaultTys down env = returnSST (getDefaultTys down)
377 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
378 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
380 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
381 tcAddSrcLoc loc m down env = m (setLoc down loc) env
383 tcGetSrcLoc :: NF_TcM s SrcLoc
384 tcGetSrcLoc down env = returnSST (getLoc down)
386 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
387 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
388 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
390 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
391 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
392 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
399 tcGetUnique :: NF_TcM s Unique
401 = readMutVarSST u_var `thenSST` \ uniq_supply ->
403 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
404 uniq = getUnique uniq_s
406 writeMutVarSST u_var new_uniq_supply `thenSST_`
409 u_var = getUniqSupplyVar down
411 tcGetUniques :: Int -> NF_TcM s [Unique]
412 tcGetUniques n down env
413 = readMutVarSST u_var `thenSST` \ uniq_supply ->
415 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
416 uniqs = getUniques n uniq_s
418 writeMutVarSST u_var new_uniq_supply `thenSST_`
421 u_var = getUniqSupplyVar down
423 uniqSMToTcM :: UniqSM a -> NF_TcM s a
424 uniqSMToTcM m down env
425 = readMutVarSST u_var `thenSST` \ uniq_supply ->
427 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
429 writeMutVarSST u_var new_uniq_supply `thenSST_`
430 returnSST (initUs uniq_s m)
432 u_var = getUniqSupplyVar down
442 [Type] -- Types used for defaulting
444 (MutableVar s UniqSupply) -- Unique supply
446 SrcLoc -- Source location
447 (ErrCtxt s) -- Error context
448 (MutableVar s (Bag Warning,
451 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
452 -- to deal with bound type variables just before error
453 -- message construction
456 -- These selectors are *local* to TcMonad.lhs
459 getTcErrs (TcDown def us loc ctxt errs) = errs
460 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
462 getDefaultTys (TcDown def us loc ctxt errs) = def
463 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
465 getLoc (TcDown def us loc ctxt errs) = loc
466 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
468 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
470 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
471 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
472 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
482 type TcError = Message
483 type TcWarning = Message
485 mkTcErr :: SrcLoc -- Where
486 -> [Message] -- Context
487 -> Message -- What went wrong
488 -> TcError -- The complete error report
490 mkTcErr locn ctxt msg sty
491 = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, ptext SLIT(": "), msg sty])
492 4 (vcat [msg sty | msg <- ctxt_to_use])
495 if opt_PprStyle_All then
500 takeAtMost :: Int -> [a] -> [a]
503 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
505 arityErr kind name n m sty
506 = hsep [ ppr sty name, ptext SLIT("should have"),
507 n_arguments <> comma, text "but has been given", int m, char '.']
509 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
510 quantity | m < n = "few"
512 n_arguments | n == 0 = ptext SLIT("no arguments")
513 | n == 1 = ptext SLIT("1 argument")
514 | True = hsep [int n, ptext SLIT("arguments")]