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