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