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