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