ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcType,
   4         TcTauType, TcPredType, TcThetaType, TcRhoType,
   5         TcTyVar, TcTyVarSet, TcClassContext,
   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, ClassContext )
  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 TcClassContext = ClassContext
  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
 221 recoverTc    :: TcM r -> TcM r -> TcM r
 222 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
 223 recoverTc recover m down env
 224   = catch (m down env) (\ _ -> recover down env)
 225
 226 returnNF_Tc      = returnTc
 227 thenNF_Tc        = thenTc
 228 thenNF_Tc_       = thenTc_
 229 fixNF_Tc         = fixTc
 230 recoverNF_Tc     = recoverTc
 231 mapNF_Tc         = mapTc
 232 foldrNF_Tc       = foldrTc
 233 foldlNF_Tc       = foldlTc
 234 listNF_Tc        = listTc
 235 mapAndUnzipNF_Tc = mapAndUnzipTc
 236 mapBagNF_Tc      = mapBagTc
 237 \end{code}
 238
 239 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 240 thread.  Ideally, this elegantly ensures that it can't zap any type
 241 variables that belong to the main thread.  But alas, the environment
 242 contains TyCon and Class environments that include TcKind stuff,
 243 which is a Royal Pain.  By the time this fork stuff is used they'll
 244 have been unified down so there won't be any kind variables, but we
 245 can't express that in the current typechecker framework.
 246
 247 So we compromise and use unsafeInterleaveIO.
 248
 249 We throw away any error messages!
 250
 251 \begin{code}
 252 forkNF_Tc :: NF_TcM r -> NF_TcM r
 253 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
 254   = do
 255         -- Get a fresh unique supply
 256         us <- readIORef u_var
 257         let (us1, us2) = splitUniqSupply us
 258         writeIORef u_var us1
 259
 260         unsafeInterleaveIO (do {
 261                 us_var'  <- newIORef us2 ;
 262                 err_var' <- newIORef (emptyBag,emptyBag) ;
 263                 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
 264                 m down' env
 265                         -- ToDo: optionally dump any error messages
 266                 })
 267 \end{code}
 268
 269 \begin{code}
 270 traceTc :: SDoc -> NF_TcM ()
 271 traceTc doc down env = printDump doc
 272
 273 ioToTc :: IO a -> NF_TcM a
 274 ioToTc io down env = io
 275 \end{code}
 276
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection{Error handling}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 \begin{code}
 285 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
 286 getErrsTc down env
 287   = readIORef (getTcErrs down)
 288
 289 failTc :: TcM a
 290 failTc down env = give_up
 291
 292 give_up :: IO a
 293 give_up = IOERROR (userError "Typecheck failed")
 294
 295 failWithTc :: Message -> TcM a                  -- Add an error message and fail
 296 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 297
 298 addErrTc :: Message -> NF_TcM ()
 299 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 300
 301 addErrsTc :: [Message] -> NF_TcM ()
 302 addErrsTc []       = returnNF_Tc ()
 303 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs)  `thenNF_Tc_` returnNF_Tc ()
 304
 305 -- The 'M' variants do the TidyEnv bit
 306 failWithTcM :: (TidyEnv, Message) -> TcM a      -- Add an error message and fail
 307 failWithTcM env_and_msg
 308   = addErrTcM env_and_msg       `thenNF_Tc_`
 309     failTc
 310
 311 checkTc :: Bool -> Message -> TcM ()            -- Check that the boolean is true
 312 checkTc True  err = returnTc ()
 313 checkTc False err = failWithTc err
 314
 315 checkTcM :: Bool -> TcM () -> TcM ()    -- Check that the boolean is true
 316 checkTcM True  err = returnTc ()
 317 checkTcM False err = err
 318
 319 checkMaybeTc :: Maybe val -> Message -> TcM val
 320 checkMaybeTc (Just val) err = returnTc val
 321 checkMaybeTc Nothing    err = failWithTc err
 322
 323 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
 324 checkMaybeTcM (Just val) err = returnTc val
 325 checkMaybeTcM Nothing    err = err
 326
 327 addErrTcM :: (TidyEnv, Message) -> NF_TcM ()    -- Add an error message but don't fail
 328 addErrTcM (tidy_env, err_msg) down env
 329   = add_err_tcm tidy_env err_msg ctxt loc down env
 330   where
 331     ctxt     = getErrCtxt down
 332     loc      = getLoc down
 333
 334 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM ()     -- Add an error message but don't fail
 335 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
 336   = add_err_tcm tidy_env err_msg full_ctxt loc down env
 337   where
 338     full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
 339
 340 add_err_tcm tidy_env err_msg ctxt loc down env
 341   = do
 342         (warns, errs) <- readIORef errs_var
 343         ctxt_msgs     <- do_ctxt tidy_env ctxt down env
 344         let err = addShortErrLocLine loc $
 345                   vcat (err_msg : ctxt_to_use ctxt_msgs)
 346         writeIORef errs_var (warns, errs `snocBag` err)
 347   where
 348     errs_var = getTcErrs down
 349
 350 do_ctxt tidy_env [] down env
 351   = return []
 352 do_ctxt tidy_env (c:cs) down env
 353   = do
 354         (tidy_env', m) <- c tidy_env down env
 355         ms             <- do_ctxt tidy_env' cs down env
 356         return (m:ms)
 357
 358 -- warnings don't have an 'M' variant
 359 warnTc :: Bool -> Message -> NF_TcM ()
 360 warnTc warn_if_true warn_msg down env
 361   | warn_if_true
 362   = do
 363         (warns,errs) <- readIORef errs_var
 364         ctxt_msgs    <- do_ctxt emptyTidyEnv ctxt down env
 365         let warn = addShortWarnLocLine loc $
 366                    vcat (warn_msg : ctxt_to_use ctxt_msgs)
 367         writeIORef errs_var (warns `snocBag` warn, errs)
 368   | otherwise
 369   = return ()
 370   where
 371     errs_var = getTcErrs down
 372     ctxt     = getErrCtxt down
 373     loc      = getLoc down
 374
 375 -- (tryTc r m) succeeds if m succeeds and generates no errors
 376 -- If m fails then r is invoked, passing the warnings and errors from m
 377 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
 378 --      (it might have recovered internally)
 379 --      If so, then r is invoked, passing the warnings and errors from m
 380
 381 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r)   -- Recovery action
 382       -> TcM r                          -- Thing to try
 383       -> TcM r
 384 tryTc recover main down env
 385   = do
 386         m_errs_var <- newIORef (emptyBag,emptyBag)
 387         catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
 388   where
 389     my_recover m_errs_var
 390       = do warns_and_errs <- readIORef m_errs_var
 391            recover warns_and_errs down env
 392
 393     my_main m_errs_var
 394        = do result <- main (setTcErrs down m_errs_var) env
 395
 396                 -- Check that m has no errors; if it has internal recovery
 397                 -- mechanisms it might "succeed" but having found a bunch of
 398                 -- errors along the way.
 399             (m_warns, m_errs) <- readIORef m_errs_var
 400             if isEmptyBag m_errs then
 401                 return result
 402               else
 403                 give_up         -- This triggers the catch
 404
 405
 406 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 407 -- If m fails then (checkNoErrsTc m) fails.
 408 -- If m succeeds, it checks whether m generated any errors messages
 409 --      (it might have recovered internally)
 410 --      If so, it fails too.
 411 -- Regardless, any errors generated by m are propagated to the enclosing context.
 412 checkNoErrsTc :: TcM r -> TcM r
 413 checkNoErrsTc main
 414   = tryTc my_recover main
 415   where
 416     my_recover (m_warns, m_errs) down env
 417         = do (warns, errs)     <- readIORef errs_var
 418              writeIORef errs_var (warns `unionBags` m_warns,
 419                                   errs  `unionBags` m_errs)
 420              give_up
 421         where
 422           errs_var = getTcErrs down
 423
 424
 425 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 426 -- otherwise it returns r.  Any error messages added by m are discarded,
 427 -- whether or not m succeeds.
 428 tryTc_ :: TcM r -> TcM r -> TcM r
 429 tryTc_ recover main
 430   = tryTc my_recover main
 431   where
 432     my_recover warns_and_errs = recover
 433
 434 -- (discardErrsTc m) runs m, but throw away all its error messages.
 435 discardErrsTc :: Either_TcM r -> Either_TcM r
 436 discardErrsTc main down env
 437   = do new_errs_var <- newIORef (emptyBag,emptyBag)
 438        main (setTcErrs down new_errs_var) env
 439 \end{code}
 440
 441
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsection{Mutable variables}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 \begin{code}
 450 tcNewMutVar :: a -> NF_TcM (TcRef a)
 451 tcNewMutVar val down env = newIORef val
 452
 453 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
 454 tcWriteMutVar var val down env = writeIORef var val
 455
 456 tcReadMutVar :: TcRef a -> NF_TcM a
 457 tcReadMutVar var down env = readIORef var
 458
 459 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
 460 tcNewMutTyVar name kind down env = newMutTyVar name kind
 461
 462 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
 463 tcNewSigTyVar name kind down env = newSigTyVar name kind
 464
 465 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 466 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 467
 468 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
 469 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 470 \end{code}
 471
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection{The environment}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 tcGetEnv :: NF_TcM TcEnv
 481 tcGetEnv down env = return env
 482
 483 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
 484 tcSetEnv new_env m down old_env = m down new_env
 485 \end{code}
 486
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection{Source location}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 \begin{code}
 495 tcGetDefaultTys :: NF_TcM [Type]
 496 tcGetDefaultTys down env = return (getDefaultTys down)
 497
 498 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
 499 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 500
 501 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
 502 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 503
 504 tcGetSrcLoc :: NF_TcM SrcLoc
 505 tcGetSrcLoc down env = return (getLoc down)
 506
 507 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
 508 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
 509
 510 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
 511                              -> TcM a -> TcM a
 512 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 513 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 514
 515 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
 516 -- Usual thing
 517 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 518 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) 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 :: Int -> NF_TcM [Unique]
 540 tcGetUniques n down env
 541   = do  uniq_supply <- readIORef u_var
 542         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 543             uniqs                     = uniqsFromSupply n 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 doptsTc :: DynFlag -> TcM Bool
 603 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
 604    = return (dopt dflag dflags)
 605
 606 getDOptsTc :: TcM DynFlags
 607 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
 608    = return dflags
 609 \end{code}
 610
 611
 612
 613
 614 %************************************************************************
 615 %*                                                                      *
 616 \subsection{TypeChecking Errors}
 617 %*                                                                      *
 618 %************************************************************************
 619
 620 \begin{code}
 621 type TcError   = Message
 622 type TcWarning = Message
 623
 624 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 625                  | otherwise          = takeAtMost 3 ctxt
 626                  where
 627                    takeAtMost :: Int -> [a] -> [a]
 628                    takeAtMost 0 ls = []
 629                    takeAtMost n [] = []
 630                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 631
 632 arityErr kind name n m
 633   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 634            n_arguments <> comma, text "but has been given", int m]
 635     where
 636         n_arguments | n == 0 = ptext SLIT("no arguments")
 637                     | n == 1 = ptext SLIT("1 argument")
 638                     | True   = hsep [int n, ptext SLIT("arguments")]
 639 \end{code}
 640
 641
 642
 643 %************************************************************************
 644 %*                                                                      *
 645 \subsection[Inst-origin]{The @InstOrigin@ type}
 646 %*                                                                      *
 647 %************************************************************************
 648
 649 The @InstOrigin@ type gives information about where a dictionary came from.
 650 This is important for decent error message reporting because dictionaries
 651 don't appear in the original source code.  Doubtless this type will evolve...
 652
 653 It appears in TcMonad because there are a couple of error-message-generation
 654 functions that deal with it.
 655
 656 \begin{code}
 657 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 658
 659 data InstOrigin
 660   = OccurrenceOf Id             -- Occurrence of an overloaded identifier
 661
 662   | IPOcc Name                  -- Occurrence of an implicit parameter
 663   | IPBind Name                 -- Binding site of an implicit parameter
 664
 665   | RecordUpdOrigin
 666
 667   | DataDeclOrigin              -- Typechecking a data declaration
 668
 669   | InstanceDeclOrigin          -- Typechecking an instance decl
 670
 671   | LiteralOrigin RenamedHsOverLit      -- Occurrence of a literal
 672
 673   | PatOrigin RenamedPat
 674
 675   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
 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 id)
 715         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 716     pp_orig (IPOcc name)
 717         = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
 718     pp_orig (IPBind name)
 719         = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
 720     pp_orig (LiteralOrigin lit)
 721         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 722     pp_orig (PatOrigin pat)
 723         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 724     pp_orig (InstanceDeclOrigin)
 725         =  ptext SLIT("an instance declaration")
 726     pp_orig (ArithSeqOrigin seq)
 727         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 728     pp_orig (SignatureOrigin)
 729         =  ptext SLIT("a type signature")
 730     pp_orig (Rank2Origin)
 731         =  ptext SLIT("a function with an overloaded argument type")
 732     pp_orig (DoOrigin)
 733         =  ptext SLIT("a do statement")
 734     pp_orig (ClassDeclOrigin)
 735         =  ptext SLIT("a class declaration")
 736     pp_orig (InstanceSpecOrigin clas ty)
 737         = hsep [text "a SPECIALIZE instance pragma; class",
 738                 quotes (ppr clas), text "type:", ppr ty]
 739     pp_orig (ValSpecOrigin name)
 740         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 741     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 742         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 743     pp_orig (CCallOrigin clabel (Just arg_expr))
 744         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 745                 text "namely", quotes (ppr arg_expr)]
 746     pp_orig (LitLitOrigin s)
 747         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 748     pp_orig (UnknownOrigin)
 749         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 750 \end{code}