ghc/compiler/typecheck/TcMonad.lhs

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