ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcType,
   4         TcTauType, TcPredType, TcThetaType, TcRhoType,
   5         TcTyVar, TcTyVarSet,
   6         TcKind,
   7
   8         TcM, NF_TcM, TcDown, TcEnv,
   9
  10         initTc,
  11         returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
  12         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  13         mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
  14         traceTc, ioToTc,
  15
  16         uniqSMToTcM,
  17
  18         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
  19         fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
  20
  21         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  22
  23         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  24         failTc, failWithTc, addErrTc, addErrsTc, warnTc,
  25         recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
  26         addErrTcM, addInstErrTcM, failWithTcM,
  27
  28         tcGetEnv, tcSetEnv,
  29         tcGetDefaultTys, tcSetDefaultTys,
  30         tcGetUnique, tcGetUniques, tcGetDFunUniq,
  31         doptsTc, getDOptsTc,
  32
  33         tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
  34         tcAddErrCtxtM, tcSetErrCtxtM,
  35         tcAddErrCtxt, tcSetErrCtxt,
  36
  37         tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
  38         tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
  39
  40         InstOrigin(..), InstLoc, pprInstLoc,
  41
  42         TcError, TcWarning, TidyEnv, emptyTidyEnv,
  43         arityErr
  44   ) where
  45
  46 #include "HsVersions.h"
  47
  48 import {-# SOURCE #-} TcEnv  ( TcEnv )
  49
  50 import RnHsSyn          ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
  51 import Type             ( Type, Kind, PredType, ThetaType, RhoType, TauType,
  52                         )
  53 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
  54
  55 import Bag              ( Bag, emptyBag, isEmptyBag,
  56                           foldBag, unitBag, unionBags, snocBag )
  57 import Class            ( Class )
  58 import Name             ( Name )
  59 import Var              ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
  60 import VarEnv           ( TidyEnv, emptyTidyEnv )
  61 import VarSet           ( TyVarSet )
  62 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply,
  63                           splitUniqSupply, mkSplitUniqSupply,
  64                           UniqSM, initUs_ )
  65 import SrcLoc           ( SrcLoc )
  66 import FiniteMap        ( FiniteMap, lookupFM, addToFM, emptyFM )
  67 import UniqFM           ( emptyUFM )
  68 import Unique           ( Unique )
  69 import CmdLineOpts
  70 import Outputable
  71
  72 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  73                           unsafeInterleaveIO, fixIO
  74                         )
  75
  76
  77 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  78 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{Types}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 type TcTyVar    = TyVar         -- Might be a mutable tyvar
  89 type TcTyVarSet = TyVarSet
  90
  91 type TcType = Type              -- A TcType can have mutable type variables
  92         -- Invariant on ForAllTy in TcTypes:
  93         --      forall a. T
  94         -- a cannot occur inside a MutTyVar in T; that is,
  95         -- T is "flattened" before quantifying over a
  96
  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        -> SrcLoc
 128        -> TcM r
 129        -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
 130
 131 initTc dflags 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 dflags [] us_var dfun_var
 141                              src_loc
 142                              [] errs_var
 143       ;
 144
 145       maybe_res <- catch (do {  res <- do_this init_down tc_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 dflags 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 dflags 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         tc_dflags :: DynFlags,
 588         tc_def    :: [Type],                    -- Types used for defaulting
 589
 590         tc_us     :: (TcRef UniqSupply),        -- Unique supply
 591         tc_ds     :: (TcRef DFunNameSupply),    -- Name supply for
 592                                                 -- dictionary function names
 593
 594         tc_loc    :: SrcLoc,                    -- Source location
 595         tc_ctxt   :: ErrCtxt,                   -- Error context
 596         tc_errs   :: (TcRef (Bag WarnMsg, Bag ErrMsg))
 597    }
 598
 599 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
 600                         -- Innermost first.  Monadic so that we have a chance
 601                         -- to deal with bound type variables just before error
 602                         -- message construction
 603
 604 type DFunNameSupply = FiniteMap String Int
 605         -- This is used as a name supply for dictionary functions
 606         -- From the inst decl we derive a string, usually by glomming together
 607         -- the class and tycon name -- but it doesn't matter exactly how;
 608         -- this map then gives a unique int for each inst decl with that
 609         -- string.  (In Haskell 98 there can only be one,
 610         -- but not so in more extended versions; also class CC type T
 611         -- and class C type TT might both give the string CCT
 612         --
 613         -- We could just use one Int for all the instance decls, but this
 614         -- way the uniques change less when you add an instance decl,
 615         -- hence less recompilation
 616 \end{code}
 617
 618 -- These selectors are *local* to TcMonad.lhs
 619
 620 \begin{code}
 621 getTcErrs (TcDown{tc_errs=errs}) = errs
 622 setTcErrs down errs = down{tc_errs=errs}
 623
 624 getDefaultTys (TcDown{tc_def=def}) = def
 625 setDefaultTys down def = down{tc_def=def}
 626
 627 getLoc (TcDown{tc_loc=loc}) = loc
 628 setLoc down loc = down{tc_loc=loc}
 629
 630 getUniqSupplyVar (TcDown{tc_us=us}) = us
 631 getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
 632
 633 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
 634 setErrCtxt down msg = down{tc_ctxt=[msg]}
 635 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 636
 637 doptsTc :: DynFlag -> TcM Bool
 638 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
 639    = return (dopt dflag dflags)
 640
 641 getDOptsTc :: TcM DynFlags
 642 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
 643    = return dflags
 644 \end{code}
 645
 646
 647
 648
 649 %************************************************************************
 650 %*                                                                      *
 651 \subsection{TypeChecking Errors}
 652 %*                                                                      *
 653 %************************************************************************
 654
 655 \begin{code}
 656 type TcError   = Message
 657 type TcWarning = Message
 658
 659 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 660                  | otherwise          = takeAtMost 3 ctxt
 661                  where
 662                    takeAtMost :: Int -> [a] -> [a]
 663                    takeAtMost 0 ls = []
 664                    takeAtMost n [] = []
 665                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 666
 667 arityErr kind name n m
 668   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 669            n_arguments <> comma, text "but has been given", int m]
 670     where
 671         n_arguments | n == 0 = ptext SLIT("no arguments")
 672                     | n == 1 = ptext SLIT("1 argument")
 673                     | True   = hsep [int n, ptext SLIT("arguments")]
 674 \end{code}
 675
 676
 677
 678 %************************************************************************
 679 %*                                                                      *
 680 \subsection[Inst-origin]{The @InstOrigin@ type}
 681 %*                                                                      *
 682 %************************************************************************
 683
 684 The @InstOrigin@ type gives information about where a dictionary came from.
 685 This is important for decent error message reporting because dictionaries
 686 don't appear in the original source code.  Doubtless this type will evolve...
 687
 688 It appears in TcMonad because there are a couple of error-message-generation
 689 functions that deal with it.
 690
 691 \begin{code}
 692 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 693
 694 data InstOrigin
 695   = OccurrenceOf Id             -- Occurrence of an overloaded identifier
 696
 697   | RecordUpdOrigin
 698
 699   | DataDeclOrigin              -- Typechecking a data declaration
 700
 701   | InstanceDeclOrigin          -- Typechecking an instance decl
 702
 703   | LiteralOrigin RenamedHsOverLit      -- Occurrence of a literal
 704
 705   | PatOrigin RenamedPat
 706
 707   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
 708
 709   | SignatureOrigin             -- A dict created from a type signature
 710   | Rank2Origin                 -- A dict created when typechecking the argument
 711                                 -- of a rank-2 typed function
 712
 713   | DoOrigin                    -- The monad for a do expression
 714
 715   | ClassDeclOrigin             -- Manufactured during a class decl
 716
 717   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 718                         Type
 719
 720         -- When specialising instances the instance info attached to
 721         -- each class is not yet ready, so we record it inside the
 722         -- origin information.  This is a bit of a hack, but it works
 723         -- fine.  (Patrick is to blame [WDP].)
 724
 725   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 726
 727         -- Argument or result of a ccall
 728         -- Dictionaries with this origin aren't actually mentioned in the
 729         -- translated term, and so need not be bound.  Nor should they
 730         -- be abstracted over.
 731
 732   | CCallOrigin         String                  -- CCall label
 733                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 734                                                 -- Just arg, for an argument
 735
 736   | LitLitOrigin        String  -- the litlit
 737
 738   | UnknownOrigin       -- Help! I give up...
 739 \end{code}
 740
 741 \begin{code}
 742 pprInstLoc :: InstLoc -> SDoc
 743 pprInstLoc (orig, locn, ctxt)
 744   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 745   where
 746     pp_orig (OccurrenceOf id)
 747         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 748     pp_orig (LiteralOrigin lit)
 749         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 750     pp_orig (PatOrigin pat)
 751         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 752     pp_orig (InstanceDeclOrigin)
 753         =  ptext SLIT("an instance declaration")
 754     pp_orig (ArithSeqOrigin seq)
 755         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 756     pp_orig (SignatureOrigin)
 757         =  ptext SLIT("a type signature")
 758     pp_orig (Rank2Origin)
 759         =  ptext SLIT("a function with an overloaded argument type")
 760     pp_orig (DoOrigin)
 761         =  ptext SLIT("a do statement")
 762     pp_orig (ClassDeclOrigin)
 763         =  ptext SLIT("a class declaration")
 764     pp_orig (InstanceSpecOrigin clas ty)
 765         = hsep [text "a SPECIALIZE instance pragma; class",
 766                 quotes (ppr clas), text "type:", ppr ty]
 767     pp_orig (ValSpecOrigin name)
 768         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 769     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 770         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 771     pp_orig (CCallOrigin clabel (Just arg_expr))
 772         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 773                 text "namely", quotes (ppr arg_expr)]
 774     pp_orig (LitLitOrigin s)
 775         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 776     pp_orig (UnknownOrigin)
 777         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 778 \end{code}