ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcM, NF_TcM, TcDown, TcEnv,
   4
   5         initTc,
   6         returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
   7         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
   8         mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
   9         traceTc, ioToTc,
  10
  11         uniqSMToTcM,
  12
  13         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
  14         fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
  15
  16         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  17
  18         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  19         failTc, failWithTc, addErrTc, addErrsTc, warnTc,
  20         recoverTc, checkNoErrsTc, ifErrsTc, recoverNF_Tc, discardErrsTc,
  21         addErrTcM, addInstErrTcM, failWithTcM,
  22
  23         tcGetEnv, tcSetEnv,
  24         tcGetDefaultTys, tcSetDefaultTys,
  25         tcGetUnique, tcGetUniques,
  26         doptsTc, getDOptsTc,
  27
  28         tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
  29         tcAddErrCtxtM, tcSetErrCtxtM,
  30         tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
  31
  32         tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
  33         tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
  34
  35         InstOrigin(..), InstLoc, pprInstLoc,
  36
  37         TcError, TcWarning, TidyEnv, emptyTidyEnv,
  38         arityErr
  39   ) where
  40
  41 #include "HsVersions.h"
  42
  43 import {-# SOURCE #-} TcEnv  ( TcEnv )
  44
  45 import HsLit            ( HsOverLit )
  46 import RnHsSyn          ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
  47 import TcType           ( Type, Kind, TyVarDetails )
  48 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
  49
  50 import Bag              ( Bag, emptyBag, isEmptyBag,
  51                           foldBag, unitBag, unionBags, snocBag )
  52 import Class            ( Class )
  53 import Name             ( Name )
  54 import Var              ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
  55 import VarEnv           ( TidyEnv, emptyTidyEnv )
  56 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply,
  57                           splitUniqSupply, mkSplitUniqSupply,
  58                           UniqSM, initUs_ )
  59 import SrcLoc           ( SrcLoc, noSrcLoc )
  60 import BasicTypes       ( IPName )
  61 import UniqFM           ( emptyUFM )
  62 import Unique           ( Unique )
  63 import CmdLineOpts
  64 import Outputable
  65
  66 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  67                           unsafeInterleaveIO, fixIO
  68                         )
  69
  70
  71 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  72 \end{code}
  73
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsection{The main monads: TcM, NF_TcM}
  78 %*                                                                      *
  79 %************************************************************************
  80
  81 \begin{code}
  82 type NF_TcM r =  TcDown -> TcEnv -> IO r        -- Can't raise UserError
  83 type TcM    r =  TcDown -> TcEnv -> IO r        -- Can raise UserError
  84
  85 type Either_TcM r =  TcDown -> TcEnv -> IO r    -- Either NF_TcM or TcM
  86         -- Used only in this file for type signatures which
  87         -- have a part that's polymorphic in whether it's NF_TcM or TcM
  88         -- E.g. thenNF_Tc
  89
  90 type TcRef a = IORef a
  91 \end{code}
  92
  93 \begin{code}
  94
  95 initTc :: DynFlags
  96        -> TcEnv
  97        -> TcM r
  98        -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
  99
 100 initTc dflags tc_env do_this
 101   = do {
 102       us       <- mkSplitUniqSupply 'a' ;
 103       us_var   <- newIORef us ;
 104       errs_var <- newIORef (emptyBag,emptyBag) ;
 105       tvs_var  <- newIORef emptyUFM ;
 106
 107       let
 108           init_down = TcDown { tc_dflags = dflags, tc_def = [],
 109                                tc_us = us_var, tc_loc = noSrcLoc,
 110                                tc_ctxt = [], tc_errs = errs_var }
 111       ;
 112
 113       maybe_res <- catch (do {  res <- do_this init_down tc_env ;
 114                                 return (Just res)})
 115                          (\_ -> return Nothing) ;
 116
 117       (warns,errs) <- readIORef errs_var ;
 118       return (maybe_res, (warns, errs))
 119     }
 120
 121 -- Monadic operations
 122
 123 returnNF_Tc :: a -> NF_TcM a
 124 returnTc    :: a -> TcM a
 125 returnTc v down env = return v
 126
 127 thenTc    :: TcM a ->    (a -> TcM b)        -> TcM b
 128 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
 129 thenTc m k down env = do { r <- m down env; k r down env }
 130
 131 thenTc_    :: TcM a    -> TcM b        -> TcM b
 132 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
 133 thenTc_ m k down env = do { m down env; k down env }
 134
 135 listTc    :: [TcM a]    -> TcM [a]
 136 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
 137 listTc []     = returnTc []
 138 listTc (x:xs) = x                       `thenTc` \ r ->
 139                 listTc xs               `thenTc` \ rs ->
 140                 returnTc (r:rs)
 141
 142 mapTc    :: (a -> TcM b)    -> [a] -> TcM [b]
 143 mapTc_   :: (a -> TcM b)    -> [a] -> TcM ()
 144 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 145 mapTc f []     = returnTc []
 146 mapTc f (x:xs) = f x            `thenTc` \ r ->
 147                  mapTc f xs     `thenTc` \ rs ->
 148                  returnTc (r:rs)
 149 mapTc_ f xs = mapTc f xs  `thenTc_` returnTc ()
 150
 151
 152 foldrTc    :: (a -> b -> TcM b)    -> b -> [a] -> TcM b
 153 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
 154 foldrTc k z []     = returnTc z
 155 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 156                      k x r
 157
 158 foldlTc    :: (a -> b -> TcM a)    -> a -> [b] -> TcM a
 159 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
 160 foldlTc k z []     = returnTc z
 161 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 162                      foldlTc k r xs
 163
 164 mapAndUnzipTc    :: (a -> TcM (b,c))    -> [a]   -> TcM ([b],[c])
 165 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a]   -> NF_TcM ([b],[c])
 166 mapAndUnzipTc f []     = returnTc ([],[])
 167 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 168                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 169                          returnTc (r1:rs1, r2:rs2)
 170
 171 mapAndUnzip3Tc    :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
 172 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 173 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 174                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 175                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 176
 177 mapBagTc    :: (a -> TcM b)    -> Bag a -> TcM (Bag b)
 178 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
 179 mapBagTc f bag
 180   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 181                         b2 `thenTc` \ r2 ->
 182                         returnTc (unionBags r1 r2))
 183             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 184             (returnTc emptyBag)
 185             bag
 186
 187 fixTc    :: (a -> TcM a)    -> TcM a
 188 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
 189 fixTc m env down = fixIO (\ loop -> m loop env down)
 190 {-# NOINLINE fixTc #-}
 191 -- aargh!  Not inlining fixTc alleviates a space leak problem.
 192 -- Normally fixTc is used with a lazy tuple match: if the optimiser is
 193 -- shown the definition of fixTc, it occasionally transforms the code
 194 -- in such a way that the code generator doesn't spot the selector
 195 -- thunks.  Sigh.
 196
 197 recoverTc    :: TcM r -> TcM r -> TcM r
 198 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
 199 recoverTc recover m down env
 200   = catch (m down env) (\ _ -> recover down env)
 201
 202 returnNF_Tc      = returnTc
 203 thenNF_Tc        = thenTc
 204 thenNF_Tc_       = thenTc_
 205 fixNF_Tc         = fixTc
 206 recoverNF_Tc     = recoverTc
 207 mapNF_Tc         = mapTc
 208 foldrNF_Tc       = foldrTc
 209 foldlNF_Tc       = foldlTc
 210 listNF_Tc        = listTc
 211 mapAndUnzipNF_Tc = mapAndUnzipTc
 212 mapBagNF_Tc      = mapBagTc
 213 \end{code}
 214
 215 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 216 thread.  Ideally, this elegantly ensures that it can't zap any type
 217 variables that belong to the main thread.  But alas, the environment
 218 contains TyCon and Class environments that include TcKind stuff,
 219 which is a Royal Pain.  By the time this fork stuff is used they'll
 220 have been unified down so there won't be any kind variables, but we
 221 can't express that in the current typechecker framework.
 222
 223 So we compromise and use unsafeInterleaveIO.
 224
 225 We throw away any error messages!
 226
 227 \begin{code}
 228 forkNF_Tc :: NF_TcM r -> NF_TcM r
 229 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
 230   = do
 231         -- Get a fresh unique supply
 232         us <- readIORef u_var
 233         let (us1, us2) = splitUniqSupply us
 234         writeIORef u_var us1
 235
 236         unsafeInterleaveIO (do {
 237                 us_var'  <- newIORef us2 ;
 238                 err_var' <- newIORef (emptyBag,emptyBag) ;
 239                 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
 240                 m down' env
 241                         -- ToDo: optionally dump any error messages
 242                 })
 243 \end{code}
 244
 245 \begin{code}
 246 traceTc :: SDoc -> NF_TcM ()
 247 traceTc doc (TcDown { tc_dflags=dflags }) env
 248   | dopt Opt_D_dump_tc_trace dflags = printDump doc
 249   | otherwise                       = return ()
 250
 251 ioToTc :: IO a -> NF_TcM a
 252 ioToTc io down env = io
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsection{Error handling}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
 264 getErrsTc down env
 265   = readIORef (getTcErrs down)
 266
 267 failTc :: TcM a
 268 failTc down env = give_up
 269
 270 give_up :: IO a
 271 give_up = ioError (userError "Typecheck failed")
 272
 273 failWithTc :: Message -> TcM a                  -- Add an error message and fail
 274 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 275
 276 addErrTc :: Message -> NF_TcM ()
 277 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 278
 279 addErrsTc :: [Message] -> NF_TcM ()
 280 addErrsTc []       = returnNF_Tc ()
 281 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs)  `thenNF_Tc_` returnNF_Tc ()
 282
 283 -- The 'M' variants do the TidyEnv bit
 284 failWithTcM :: (TidyEnv, Message) -> TcM a      -- Add an error message and fail
 285 failWithTcM env_and_msg
 286   = addErrTcM env_and_msg       `thenNF_Tc_`
 287     failTc
 288
 289 checkTc :: Bool -> Message -> TcM ()            -- Check that the boolean is true
 290 checkTc True  err = returnTc ()
 291 checkTc False err = failWithTc err
 292
 293 checkTcM :: Bool -> TcM () -> TcM ()    -- Check that the boolean is true
 294 checkTcM True  err = returnTc ()
 295 checkTcM False err = err
 296
 297 checkMaybeTc :: Maybe val -> Message -> TcM val
 298 checkMaybeTc (Just val) err = returnTc val
 299 checkMaybeTc Nothing    err = failWithTc err
 300
 301 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
 302 checkMaybeTcM (Just val) err = returnTc val
 303 checkMaybeTcM Nothing    err = err
 304
 305 addErrTcM :: (TidyEnv, Message) -> NF_TcM ()    -- Add an error message but don't fail
 306 addErrTcM (tidy_env, err_msg) down env
 307   = add_err_tcm tidy_env err_msg ctxt loc down env
 308   where
 309     ctxt     = getErrCtxt down
 310     loc      = getLoc down
 311
 312 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM ()     -- Add an error message but don't fail
 313 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
 314   = add_err_tcm tidy_env err_msg full_ctxt loc down env
 315   where
 316     full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
 317
 318 add_err_tcm tidy_env err_msg ctxt loc down env
 319   = do
 320         (warns, errs) <- readIORef errs_var
 321         ctxt_msgs     <- do_ctxt tidy_env ctxt down env
 322         let err = addShortErrLocLine loc $
 323                   vcat (err_msg : ctxt_to_use ctxt_msgs)
 324         writeIORef errs_var (warns, errs `snocBag` err)
 325   where
 326     errs_var = getTcErrs down
 327
 328 do_ctxt tidy_env [] down env
 329   = return []
 330 do_ctxt tidy_env (c:cs) down env
 331   = do
 332         (tidy_env', m) <- c tidy_env down env
 333         ms             <- do_ctxt tidy_env' cs down env
 334         return (m:ms)
 335
 336 -- warnings don't have an 'M' variant
 337 warnTc :: Bool -> Message -> NF_TcM ()
 338 warnTc warn_if_true warn_msg down env
 339   | warn_if_true
 340   = do
 341         (warns,errs) <- readIORef errs_var
 342         ctxt_msgs    <- do_ctxt emptyTidyEnv ctxt down env
 343         let warn = addShortWarnLocLine loc $
 344                    vcat (warn_msg : ctxt_to_use ctxt_msgs)
 345         writeIORef errs_var (warns `snocBag` warn, errs)
 346   | otherwise
 347   = return ()
 348   where
 349     errs_var = getTcErrs down
 350     ctxt     = getErrCtxt down
 351     loc      = getLoc down
 352
 353 -- (tryTc r m) succeeds if m succeeds and generates no errors
 354 -- If m fails then r is invoked, passing the warnings and errors from m
 355 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
 356 --      (it might have recovered internally)
 357 --      If so, then r is invoked, passing the warnings and errors from m
 358
 359 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r)   -- Recovery action
 360       -> TcM r                          -- Thing to try
 361       -> TcM r
 362 tryTc recover main down env
 363   = do
 364         m_errs_var <- newIORef (emptyBag,emptyBag)
 365         catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
 366   where
 367     errs_var = getTcErrs down
 368
 369     my_recover m_errs_var
 370       = do warns_and_errs <- readIORef m_errs_var
 371            recover warns_and_errs down env
 372
 373     my_main m_errs_var
 374        = do result <- main (setTcErrs down m_errs_var) env
 375
 376                 -- Check that m has no errors; if it has internal recovery
 377                 -- mechanisms it might "succeed" but having found a bunch of
 378                 -- errors along the way.
 379             (m_warns, m_errs) <- readIORef m_errs_var
 380             if isEmptyBag m_errs then
 381                 -- No errors, so return normally, but don't lose the warnings
 382                 if isEmptyBag m_warns then
 383                    return result
 384                 else
 385                    do (warns, errs) <- readIORef errs_var
 386                       writeIORef errs_var (warns `unionBags` m_warns, errs)
 387                       return result
 388               else
 389                 give_up         -- This triggers the catch
 390
 391
 392 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 393 -- If m fails then (checkNoErrsTc m) fails.
 394 -- If m succeeds, it checks whether m generated any errors messages
 395 --      (it might have recovered internally)
 396 --      If so, it fails too.
 397 -- Regardless, any errors generated by m are propagated to the enclosing context.
 398 checkNoErrsTc :: TcM r -> TcM r
 399 checkNoErrsTc main
 400   = tryTc my_recover main
 401   where
 402     my_recover (m_warns, m_errs) down env
 403         = do (warns, errs)     <- readIORef errs_var
 404              writeIORef errs_var (warns `unionBags` m_warns,
 405                                   errs  `unionBags` m_errs)
 406              give_up
 407         where
 408           errs_var = getTcErrs down
 409
 410
 411 ifErrsTc :: TcM r -> TcM r -> TcM r
 412 --      ifErrsTc bale_out main
 413 -- does 'bale_out' if there are errors in errors collection
 414 -- and does 'main' otherwise
 415 -- Useful to avoid error cascades
 416
 417 ifErrsTc bale_out main
 418   = getErrsTc   `thenNF_Tc` \ (warns, errs) ->
 419     if isEmptyBag errs then
 420            main
 421     else
 422            bale_out
 423
 424 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 425 -- otherwise it returns r.  Any error messages added by m are discarded,
 426 -- whether or not m succeeds.
 427 tryTc_ :: TcM r -> TcM r -> TcM r
 428 tryTc_ recover main
 429   = tryTc my_recover main
 430   where
 431     my_recover warns_and_errs = recover
 432
 433 -- (discardErrsTc m) runs m, but throw away all its error messages.
 434 discardErrsTc :: Either_TcM r -> Either_TcM r
 435 discardErrsTc main down env
 436   = do new_errs_var <- newIORef (emptyBag,emptyBag)
 437        main (setTcErrs down new_errs_var) env
 438 \end{code}
 439
 440
 441
 442 %************************************************************************
 443 %*                                                                      *
 444 \subsection{Mutable variables}
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 \begin{code}
 449 tcNewMutVar :: a -> NF_TcM (TcRef a)
 450 tcNewMutVar val down env = newIORef val
 451
 452 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
 453 tcWriteMutVar var val down env = writeIORef var val
 454
 455 tcReadMutVar :: TcRef a -> NF_TcM a
 456 tcReadMutVar var down env = readIORef var
 457
 458 tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
 459 tcNewMutTyVar name kind details down env = newMutTyVar name kind details
 460
 461 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 462 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 463
 464 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
 465 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection{The environment}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 tcGetEnv :: NF_TcM TcEnv
 477 tcGetEnv down env = return env
 478
 479 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
 480 tcSetEnv new_env m down old_env = m down new_env
 481 \end{code}
 482
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection{Source location}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 \begin{code}
 491 tcGetDefaultTys :: NF_TcM [Type]
 492 tcGetDefaultTys down env = return (getDefaultTys down)
 493
 494 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
 495 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 496
 497 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
 498 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 499
 500 tcGetSrcLoc :: NF_TcM SrcLoc
 501 tcGetSrcLoc down env = return (getLoc down)
 502
 503 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
 504 tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
 505    = return (origin, loc, ctxt)
 506
 507 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
 508                              -> TcM a -> TcM a
 509 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 510 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 511
 512 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
 513 -- Usual thing
 514 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 515 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 516
 517 tcPopErrCtxt :: Either_TcM r -> Either_TcM  r
 518 tcPopErrCtxt m down env = m (popErrCtxt down) env
 519 \end{code}
 520
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsection{Unique supply}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 \begin{code}
 529 tcGetUnique :: NF_TcM Unique
 530 tcGetUnique down env
 531   = do  uniq_supply <- readIORef u_var
 532         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 533             uniq                      = uniqFromSupply uniq_s
 534         writeIORef u_var new_uniq_supply
 535         return uniq
 536   where
 537     u_var = getUniqSupplyVar down
 538
 539 tcGetUniques :: NF_TcM [Unique]
 540 tcGetUniques down env
 541   = do  uniq_supply <- readIORef u_var
 542         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 543             uniqs                     = uniqsFromSupply uniq_s
 544         writeIORef u_var new_uniq_supply
 545         return uniqs
 546   where
 547     u_var = getUniqSupplyVar down
 548
 549 uniqSMToTcM :: UniqSM a -> NF_TcM a
 550 uniqSMToTcM m down env
 551   = do  uniq_supply <- readIORef u_var
 552         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 553         writeIORef u_var new_uniq_supply
 554         return (initUs_ uniq_s m)
 555   where
 556     u_var = getUniqSupplyVar down
 557 \end{code}
 558
 559
 560
 561 %************************************************************************
 562 %*                                                                      *
 563 \subsection{TcDown}
 564 %*                                                                      *
 565 %************************************************************************
 566
 567 \begin{code}
 568 data TcDown
 569    = TcDown {
 570         tc_dflags :: DynFlags,
 571         tc_def    :: [Type],                    -- Types used for defaulting
 572         tc_us     :: (TcRef UniqSupply),        -- Unique supply
 573         tc_loc    :: SrcLoc,                    -- Source location
 574         tc_ctxt   :: ErrCtxt,                   -- Error context
 575         tc_errs   :: (TcRef (Bag WarnMsg, Bag ErrMsg))
 576    }
 577
 578 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
 579                         -- Innermost first.  Monadic so that we have a chance
 580                         -- to deal with bound type variables just before error
 581                         -- message construction
 582 \end{code}
 583
 584 -- These selectors are *local* to TcMonad.lhs
 585
 586 \begin{code}
 587 getTcErrs (TcDown{tc_errs=errs}) = errs
 588 setTcErrs down errs = down{tc_errs=errs}
 589
 590 getDefaultTys (TcDown{tc_def=def}) = def
 591 setDefaultTys down def = down{tc_def=def}
 592
 593 getLoc (TcDown{tc_loc=loc}) = loc
 594 setLoc down loc = down{tc_loc=loc}
 595
 596 getUniqSupplyVar (TcDown{tc_us=us}) = us
 597
 598 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
 599 setErrCtxt down msg = down{tc_ctxt=[msg]}
 600 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 601
 602 popErrCtxt down = case tc_ctxt down of
 603                         []     -> down
 604                         m : ms -> down{tc_ctxt = ms}
 605
 606 doptsTc :: DynFlag -> NF_TcM Bool
 607 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
 608    = return (dopt dflag dflags)
 609
 610 getDOptsTc :: NF_TcM DynFlags
 611 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
 612    = return dflags
 613 \end{code}
 614
 615
 616
 617
 618 %************************************************************************
 619 %*                                                                      *
 620 \subsection{TypeChecking Errors}
 621 %*                                                                      *
 622 %************************************************************************
 623
 624 \begin{code}
 625 type TcError   = Message
 626 type TcWarning = Message
 627
 628 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 629                  | otherwise          = take 3 ctxt
 630
 631 arityErr kind name n m
 632   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 633            n_arguments <> comma, text "but has been given", int m]
 634     where
 635         n_arguments | n == 0 = ptext SLIT("no arguments")
 636                     | n == 1 = ptext SLIT("1 argument")
 637                     | True   = hsep [int n, ptext SLIT("arguments")]
 638 \end{code}
 639
 640
 641
 642 %************************************************************************
 643 %*                                                                      *
 644 \subsection[Inst-origin]{The @InstOrigin@ type}
 645 %*                                                                      *
 646 %************************************************************************
 647
 648 The @InstOrigin@ type gives information about where a dictionary came from.
 649 This is important for decent error message reporting because dictionaries
 650 don't appear in the original source code.  Doubtless this type will evolve...
 651
 652 It appears in TcMonad because there are a couple of error-message-generation
 653 functions that deal with it.
 654
 655 \begin{code}
 656 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 657
 658 data InstOrigin
 659   = OccurrenceOf Name           -- Occurrence of an overloaded identifier
 660
 661   | IPOcc (IPName Name)         -- Occurrence of an implicit parameter
 662   | IPBind (IPName Name)        -- Binding site of an implicit parameter
 663
 664   | RecordUpdOrigin
 665
 666   | DataDeclOrigin              -- Typechecking a data declaration
 667
 668   | InstanceDeclOrigin          -- Typechecking an instance decl
 669
 670   | LiteralOrigin HsOverLit     -- Occurrence of a literal
 671
 672   | PatOrigin RenamedPat
 673
 674   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
 675   | PArrSeqOrigin  RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
 676
 677   | SignatureOrigin             -- A dict created from a type signature
 678   | Rank2Origin                 -- A dict created when typechecking the argument
 679                                 -- of a rank-2 typed function
 680
 681   | DoOrigin                    -- The monad for a do expression
 682
 683   | ClassDeclOrigin             -- Manufactured during a class decl
 684
 685   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 686                         Type
 687
 688         -- When specialising instances the instance info attached to
 689         -- each class is not yet ready, so we record it inside the
 690         -- origin information.  This is a bit of a hack, but it works
 691         -- fine.  (Patrick is to blame [WDP].)
 692
 693   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 694
 695         -- Argument or result of a ccall
 696         -- Dictionaries with this origin aren't actually mentioned in the
 697         -- translated term, and so need not be bound.  Nor should they
 698         -- be abstracted over.
 699
 700   | CCallOrigin         String                  -- CCall label
 701                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 702                                                 -- Just arg, for an argument
 703
 704   | LitLitOrigin        String  -- the litlit
 705
 706   | UnknownOrigin       -- Help! I give up...
 707 \end{code}
 708
 709 \begin{code}
 710 pprInstLoc :: InstLoc -> SDoc
 711 pprInstLoc (orig, locn, ctxt)
 712   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 713   where
 714     pp_orig (OccurrenceOf name)
 715         = hsep [ptext SLIT("use of"), quotes (ppr name)]
 716     pp_orig (IPOcc name)
 717         = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
 718     pp_orig (IPBind name)
 719         = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
 720     pp_orig RecordUpdOrigin
 721         = ptext SLIT("a record update")
 722     pp_orig DataDeclOrigin
 723         = ptext SLIT("the data type declaration")
 724     pp_orig InstanceDeclOrigin
 725         = ptext SLIT("the instance declaration")
 726     pp_orig (LiteralOrigin lit)
 727         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 728     pp_orig (PatOrigin pat)
 729         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 730     pp_orig (ArithSeqOrigin seq)
 731         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 732     pp_orig (PArrSeqOrigin seq)
 733         = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
 734     pp_orig (SignatureOrigin)
 735         =  ptext SLIT("a type signature")
 736     pp_orig (Rank2Origin)
 737         =  ptext SLIT("a function with an overloaded argument type")
 738     pp_orig (DoOrigin)
 739         =  ptext SLIT("a do statement")
 740     pp_orig (ClassDeclOrigin)
 741         =  ptext SLIT("a class declaration")
 742     pp_orig (InstanceSpecOrigin clas ty)
 743         = hsep [text "a SPECIALIZE instance pragma; class",
 744                 quotes (ppr clas), text "type:", ppr ty]
 745     pp_orig (ValSpecOrigin name)
 746         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 747     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 748         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 749     pp_orig (CCallOrigin clabel (Just arg_expr))
 750         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 751                 text "namely", quotes (ppr arg_expr)]
 752     pp_orig (LitLitOrigin s)
 753         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 754     pp_orig (UnknownOrigin)
 755         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 756 \end{code}