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,
  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 RnHsSyn          ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
  51 import Type             ( Type, Kind, PredType, ThetaType, RhoType, TauType,
  52                         )
  53 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
  54
  55 import Bag              ( Bag, emptyBag, isEmptyBag,
  56                           foldBag, unitBag, unionBags, snocBag )
  57 import Class            ( Class )
  58 import Name             ( Name )
  59 import Var              ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
  60 import VarEnv           ( TidyEnv, emptyTidyEnv )
  61 import VarSet           ( TyVarSet )
  62 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply,
  63                           splitUniqSupply, mkSplitUniqSupply,
  64                           UniqSM, initUs_ )
  65 import SrcLoc           ( SrcLoc, noSrcLoc )
  66 import UniqFM           ( emptyUFM )
  67 import Unique           ( Unique )
  68 import CmdLineOpts
  69 import Outputable
  70
  71 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  72                           unsafeInterleaveIO, fixIO
  73                         )
  74
  75
  76 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{Types}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 type TcTyVar    = TyVar         -- Might be a mutable tyvar
  88 type TcTyVarSet = TyVarSet
  89
  90 type TcType = Type              -- A TcType can have mutable type variables
  91         -- Invariant on ForAllTy in TcTypes:
  92         --      forall a. T
  93         -- a cannot occur inside a MutTyVar in T; that is,
  94         -- T is "flattened" before quantifying over a
  95
  96 type TcPredType  = PredType
  97 type TcThetaType = ThetaType
  98 type TcRhoType   = RhoType
  99 type TcTauType   = TauType
 100 type TcKind      = TcType
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{The main monads: TcM, NF_TcM}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 type NF_TcM r =  TcDown -> TcEnv -> IO r        -- Can't raise UserError
 112 type TcM    r =  TcDown -> TcEnv -> IO r        -- Can raise UserError
 113
 114 type Either_TcM r =  TcDown -> TcEnv -> IO r    -- Either NF_TcM or TcM
 115         -- Used only in this file for type signatures which
 116         -- have a part that's polymorphic in whether it's NF_TcM or TcM
 117         -- E.g. thenNF_Tc
 118
 119 type TcRef a = IORef a
 120 \end{code}
 121
 122 \begin{code}
 123
 124 initTc :: DynFlags
 125        -> TcEnv
 126        -> TcM r
 127        -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
 128
 129 initTc dflags tc_env do_this
 130   = do {
 131       us       <- mkSplitUniqSupply 'a' ;
 132       us_var   <- newIORef us ;
 133       errs_var <- newIORef (emptyBag,emptyBag) ;
 134       tvs_var  <- newIORef emptyUFM ;
 135
 136       let
 137           init_down = TcDown { tc_dflags = dflags, tc_def = [],
 138                                tc_us = us_var, tc_loc = noSrcLoc,
 139                                tc_ctxt = [], tc_errs = errs_var }
 140       ;
 141
 142       maybe_res <- catch (do {  res <- do_this init_down tc_env ;
 143                                 return (Just res)})
 144                          (\_ -> return Nothing) ;
 145
 146       (warns,errs) <- readIORef errs_var ;
 147       return (maybe_res, (warns, errs))
 148     }
 149
 150 -- Monadic operations
 151
 152 returnNF_Tc :: a -> NF_TcM a
 153 returnTc    :: a -> TcM a
 154 returnTc v down env = return v
 155
 156 thenTc    :: TcM a ->    (a -> TcM b)        -> TcM b
 157 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
 158 thenTc m k down env = do { r <- m down env; k r down env }
 159
 160 thenTc_    :: TcM a    -> TcM b        -> TcM b
 161 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
 162 thenTc_ m k down env = do { m down env; k down env }
 163
 164 listTc    :: [TcM a]    -> TcM [a]
 165 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
 166 listTc []     = returnTc []
 167 listTc (x:xs) = x                       `thenTc` \ r ->
 168                 listTc xs               `thenTc` \ rs ->
 169                 returnTc (r:rs)
 170
 171 mapTc    :: (a -> TcM b)    -> [a] -> TcM [b]
 172 mapTc_   :: (a -> TcM b)    -> [a] -> TcM ()
 173 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 174 mapTc f []     = returnTc []
 175 mapTc f (x:xs) = f x            `thenTc` \ r ->
 176                  mapTc f xs     `thenTc` \ rs ->
 177                  returnTc (r:rs)
 178 mapTc_ f xs = mapTc f xs  `thenTc_` returnTc ()
 179
 180
 181 foldrTc    :: (a -> b -> TcM b)    -> b -> [a] -> TcM b
 182 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
 183 foldrTc k z []     = returnTc z
 184 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 185                      k x r
 186
 187 foldlTc    :: (a -> b -> TcM a)    -> a -> [b] -> TcM a
 188 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
 189 foldlTc k z []     = returnTc z
 190 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 191                      foldlTc k r xs
 192
 193 mapAndUnzipTc    :: (a -> TcM (b,c))    -> [a]   -> TcM ([b],[c])
 194 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a]   -> NF_TcM ([b],[c])
 195 mapAndUnzipTc f []     = returnTc ([],[])
 196 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 197                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 198                          returnTc (r1:rs1, r2:rs2)
 199
 200 mapAndUnzip3Tc    :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
 201 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 202 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 203                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 204                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 205
 206 mapBagTc    :: (a -> TcM b)    -> Bag a -> TcM (Bag b)
 207 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
 208 mapBagTc f bag
 209   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 210                         b2 `thenTc` \ r2 ->
 211                         returnTc (unionBags r1 r2))
 212             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 213             (returnTc emptyBag)
 214             bag
 215
 216 fixTc    :: (a -> TcM a)    -> TcM a
 217 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
 218 fixTc m env down = fixIO (\ loop -> m loop env down)
 219
 220 recoverTc    :: TcM r -> TcM r -> TcM r
 221 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
 222 recoverTc recover m down env
 223   = catch (m down env) (\ _ -> recover down env)
 224
 225 returnNF_Tc      = returnTc
 226 thenNF_Tc        = thenTc
 227 thenNF_Tc_       = thenTc_
 228 fixNF_Tc         = fixTc
 229 recoverNF_Tc     = recoverTc
 230 mapNF_Tc         = mapTc
 231 foldrNF_Tc       = foldrTc
 232 foldlNF_Tc       = foldlTc
 233 listNF_Tc        = listTc
 234 mapAndUnzipNF_Tc = mapAndUnzipTc
 235 mapBagNF_Tc      = mapBagTc
 236 \end{code}
 237
 238 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 239 thread.  Ideally, this elegantly ensures that it can't zap any type
 240 variables that belong to the main thread.  But alas, the environment
 241 contains TyCon and Class environments that include TcKind stuff,
 242 which is a Royal Pain.  By the time this fork stuff is used they'll
 243 have been unified down so there won't be any kind variables, but we
 244 can't express that in the current typechecker framework.
 245
 246 So we compromise and use unsafeInterleaveSST.
 247
 248 We throw away any error messages!
 249
 250 \begin{code}
 251 forkNF_Tc :: NF_TcM r -> NF_TcM r
 252 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
 253   = do
 254         -- Get a fresh unique supply
 255         us <- readIORef u_var
 256         let (us1, us2) = splitUniqSupply us
 257         writeIORef u_var us1
 258
 259         unsafeInterleaveIO (do {
 260                 us_var'  <- newIORef us2 ;
 261                 err_var' <- newIORef (emptyBag,emptyBag) ;
 262                 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
 263                 m down' env
 264                         -- ToDo: optionally dump any error messages
 265                 })
 266 \end{code}
 267
 268 \begin{code}
 269 traceTc :: SDoc -> NF_TcM ()
 270 traceTc doc down env = printDump doc
 271
 272 ioToTc :: IO a -> NF_TcM a
 273 ioToTc io down env = io
 274 \end{code}
 275
 276
 277 %************************************************************************
 278 %*                                                                      *
 279 \subsection{Error handling}
 280 %*                                                                      *
 281 %************************************************************************
 282
 283 \begin{code}
 284 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
 285 getErrsTc down env
 286   = readIORef (getTcErrs down)
 287
 288 failTc :: TcM a
 289 failTc down env = give_up
 290
 291 give_up :: IO a
 292 give_up = IOERROR (userError "Typecheck failed")
 293
 294 failWithTc :: Message -> TcM a                  -- Add an error message and fail
 295 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 296
 297 addErrTc :: Message -> NF_TcM ()
 298 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 299
 300 addErrsTc :: [Message] -> NF_TcM ()
 301 addErrsTc []       = returnNF_Tc ()
 302 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs)  `thenNF_Tc_` returnNF_Tc ()
 303
 304 -- The 'M' variants do the TidyEnv bit
 305 failWithTcM :: (TidyEnv, Message) -> TcM a      -- Add an error message and fail
 306 failWithTcM env_and_msg
 307   = addErrTcM env_and_msg       `thenNF_Tc_`
 308     failTc
 309
 310 checkTc :: Bool -> Message -> TcM ()            -- Check that the boolean is true
 311 checkTc True  err = returnTc ()
 312 checkTc False err = failWithTc err
 313
 314 checkTcM :: Bool -> TcM () -> TcM ()    -- Check that the boolean is true
 315 checkTcM True  err = returnTc ()
 316 checkTcM False err = err
 317
 318 checkMaybeTc :: Maybe val -> Message -> TcM val
 319 checkMaybeTc (Just val) err = returnTc val
 320 checkMaybeTc Nothing    err = failWithTc err
 321
 322 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
 323 checkMaybeTcM (Just val) err = returnTc val
 324 checkMaybeTcM Nothing    err = err
 325
 326 addErrTcM :: (TidyEnv, Message) -> NF_TcM ()    -- Add an error message but don't fail
 327 addErrTcM (tidy_env, err_msg) down env
 328   = add_err_tcm tidy_env err_msg ctxt loc down env
 329   where
 330     ctxt     = getErrCtxt down
 331     loc      = getLoc down
 332
 333 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM ()     -- Add an error message but don't fail
 334 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
 335   = add_err_tcm tidy_env err_msg full_ctxt loc down env
 336   where
 337     full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
 338
 339 add_err_tcm tidy_env err_msg ctxt loc down env
 340   = do
 341         (warns, errs) <- readIORef errs_var
 342         ctxt_msgs     <- do_ctxt tidy_env ctxt down env
 343         let err = addShortErrLocLine loc $
 344                   vcat (err_msg : ctxt_to_use ctxt_msgs)
 345         writeIORef errs_var (warns, errs `snocBag` err)
 346   where
 347     errs_var = getTcErrs down
 348
 349 do_ctxt tidy_env [] down env
 350   = return []
 351 do_ctxt tidy_env (c:cs) down env
 352   = do
 353         (tidy_env', m) <- c tidy_env down env
 354         ms             <- do_ctxt tidy_env' cs down env
 355         return (m:ms)
 356
 357 -- warnings don't have an 'M' variant
 358 warnTc :: Bool -> Message -> NF_TcM ()
 359 warnTc warn_if_true warn_msg down env
 360   | warn_if_true
 361   = do
 362         (warns,errs) <- readIORef errs_var
 363         ctxt_msgs    <- do_ctxt emptyTidyEnv ctxt down env
 364         let warn = addShortWarnLocLine loc $
 365                    vcat (warn_msg : ctxt_to_use ctxt_msgs)
 366         writeIORef errs_var (warns `snocBag` warn, errs)
 367   | otherwise
 368   = return ()
 369   where
 370     errs_var = getTcErrs down
 371     ctxt     = getErrCtxt down
 372     loc      = getLoc down
 373
 374 -- (tryTc r m) succeeds if m succeeds and generates no errors
 375 -- If m fails then r is invoked, passing the warnings and errors from m
 376 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
 377 --      (it might have recovered internally)
 378 --      If so, then r is invoked, passing the warnings and errors from m
 379
 380 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r)   -- Recovery action
 381       -> TcM r                          -- Thing to try
 382       -> TcM r
 383 tryTc recover main down env
 384   = do
 385         m_errs_var <- newIORef (emptyBag,emptyBag)
 386         catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
 387   where
 388     my_recover m_errs_var
 389       = do warns_and_errs <- readIORef m_errs_var
 390            recover warns_and_errs down env
 391
 392     my_main m_errs_var
 393        = do result <- main (setTcErrs down m_errs_var) env
 394
 395                 -- Check that m has no errors; if it has internal recovery
 396                 -- mechanisms it might "succeed" but having found a bunch of
 397                 -- errors along the way.
 398             (m_warns, m_errs) <- readIORef m_errs_var
 399             if isEmptyBag m_errs then
 400                 return result
 401               else
 402                 give_up         -- This triggers the catch
 403
 404
 405 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 406 -- If m fails then (checkNoErrsTc m) fails.
 407 -- If m succeeds, it checks whether m generated any errors messages
 408 --      (it might have recovered internally)
 409 --      If so, it fails too.
 410 -- Regardless, any errors generated by m are propagated to the enclosing context.
 411 checkNoErrsTc :: TcM r -> TcM r
 412 checkNoErrsTc main
 413   = tryTc my_recover main
 414   where
 415     my_recover (m_warns, m_errs) down env
 416         = do (warns, errs)     <- readIORef errs_var
 417              writeIORef errs_var (warns `unionBags` m_warns,
 418                                   errs  `unionBags` m_errs)
 419              give_up
 420         where
 421           errs_var = getTcErrs down
 422
 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 -> NF_TcM TyVar
 459 tcNewMutTyVar name kind down env = newMutTyVar name kind
 460
 461 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
 462 tcNewSigTyVar name kind down env = newSigTyVar name kind
 463
 464 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 465 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 466
 467 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
 468 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 469 \end{code}
 470
 471
 472 %************************************************************************
 473 %*                                                                      *
 474 \subsection{The environment}
 475 %*                                                                      *
 476 %************************************************************************
 477
 478 \begin{code}
 479 tcGetEnv :: NF_TcM TcEnv
 480 tcGetEnv down env = return env
 481
 482 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
 483 tcSetEnv new_env m down old_env = m down new_env
 484 \end{code}
 485
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsection{Source location}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 \begin{code}
 494 tcGetDefaultTys :: NF_TcM [Type]
 495 tcGetDefaultTys down env = return (getDefaultTys down)
 496
 497 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
 498 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 499
 500 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
 501 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 502
 503 tcGetSrcLoc :: NF_TcM SrcLoc
 504 tcGetSrcLoc down env = return (getLoc down)
 505
 506 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
 507 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
 508
 509 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
 510                              -> TcM a -> TcM a
 511 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 512 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 513
 514 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
 515 -- Usual thing
 516 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 517 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) 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 :: Int -> NF_TcM [Unique]
 539 tcGetUniques n down env
 540   = do  uniq_supply <- readIORef u_var
 541         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 542             uniqs                     = uniqsFromSupply n 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 doptsTc :: DynFlag -> TcM Bool
 602 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
 603    = return (dopt dflag dflags)
 604
 605 getDOptsTc :: TcM DynFlags
 606 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
 607    = return dflags
 608 \end{code}
 609
 610
 611
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection{TypeChecking Errors}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 \begin{code}
 620 type TcError   = Message
 621 type TcWarning = Message
 622
 623 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 624                  | otherwise          = takeAtMost 3 ctxt
 625                  where
 626                    takeAtMost :: Int -> [a] -> [a]
 627                    takeAtMost 0 ls = []
 628                    takeAtMost n [] = []
 629                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 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 Id             -- Occurrence of an overloaded identifier
 660
 661   | RecordUpdOrigin
 662
 663   | DataDeclOrigin              -- Typechecking a data declaration
 664
 665   | InstanceDeclOrigin          -- Typechecking an instance decl
 666
 667   | LiteralOrigin RenamedHsOverLit      -- Occurrence of a literal
 668
 669   | PatOrigin RenamedPat
 670
 671   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
 672
 673   | SignatureOrigin             -- A dict created from a type signature
 674   | Rank2Origin                 -- A dict created when typechecking the argument
 675                                 -- of a rank-2 typed function
 676
 677   | DoOrigin                    -- The monad for a do expression
 678
 679   | ClassDeclOrigin             -- Manufactured during a class decl
 680
 681   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 682                         Type
 683
 684         -- When specialising instances the instance info attached to
 685         -- each class is not yet ready, so we record it inside the
 686         -- origin information.  This is a bit of a hack, but it works
 687         -- fine.  (Patrick is to blame [WDP].)
 688
 689   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 690
 691         -- Argument or result of a ccall
 692         -- Dictionaries with this origin aren't actually mentioned in the
 693         -- translated term, and so need not be bound.  Nor should they
 694         -- be abstracted over.
 695
 696   | CCallOrigin         String                  -- CCall label
 697                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 698                                                 -- Just arg, for an argument
 699
 700   | LitLitOrigin        String  -- the litlit
 701
 702   | UnknownOrigin       -- Help! I give up...
 703 \end{code}
 704
 705 \begin{code}
 706 pprInstLoc :: InstLoc -> SDoc
 707 pprInstLoc (orig, locn, ctxt)
 708   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 709   where
 710     pp_orig (OccurrenceOf id)
 711         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 712     pp_orig (LiteralOrigin lit)
 713         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 714     pp_orig (PatOrigin pat)
 715         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 716     pp_orig (InstanceDeclOrigin)
 717         =  ptext SLIT("an instance declaration")
 718     pp_orig (ArithSeqOrigin seq)
 719         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 720     pp_orig (SignatureOrigin)
 721         =  ptext SLIT("a type signature")
 722     pp_orig (Rank2Origin)
 723         =  ptext SLIT("a function with an overloaded argument type")
 724     pp_orig (DoOrigin)
 725         =  ptext SLIT("a do statement")
 726     pp_orig (ClassDeclOrigin)
 727         =  ptext SLIT("a class declaration")
 728     pp_orig (InstanceSpecOrigin clas ty)
 729         = hsep [text "a SPECIALIZE instance pragma; class",
 730                 quotes (ppr clas), text "type:", ppr ty]
 731     pp_orig (ValSpecOrigin name)
 732         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 733     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 734         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 735     pp_orig (CCallOrigin clabel (Just arg_expr))
 736         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 737                 text "namely", quotes (ppr arg_expr)]
 738     pp_orig (LitLitOrigin s)
 739         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 740     pp_orig (UnknownOrigin)
 741         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 742 \end{code}