ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcType,
   4         TcTauType, TcPredType, TcThetaType, TcRhoType,
   5         TcTyVar, TcTyVarSet,
   6         TcKind,
   7
   8         TcM, NF_TcM, TcDown, TcEnv,
   9
  10         initTc,
  11         returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
  12         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  13         mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
  14         traceTc, ioToTc,
  15
  16         uniqSMToTcM,
  17
  18         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
  19         fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
  20
  21         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  22
  23         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  24         failTc, failWithTc, addErrTc, addErrsTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
  25         addErrTcM, addInstErrTcM, failWithTcM,
  26
  27         tcGetEnv, tcSetEnv,
  28         tcGetDefaultTys, tcSetDefaultTys,
  29         tcGetUnique, tcGetUniques, tcGetDFunUniq,
  30         doptsTc,
  31
  32         tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
  33         tcAddErrCtxtM, tcSetErrCtxtM,
  34         tcAddErrCtxt, tcSetErrCtxt,
  35
  36         tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
  37         tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
  38
  39         InstOrigin(..), InstLoc, pprInstLoc,
  40
  41         TcError, TcWarning, TidyEnv, emptyTidyEnv,
  42         arityErr
  43   ) where
  44
  45 #include "HsVersions.h"
  46
  47 import {-# SOURCE #-} TcEnv  ( TcEnv )
  48
  49 import RnHsSyn          ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
  50 import Type             ( Type, Kind, PredType, ThetaType, RhoType, TauType,
  51                         )
  52 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
  53 import CmdLineOpts      ( DynFlags, opt_PprStyle_Debug )
  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, noSrcLoc )
  66 import FiniteMap        ( FiniteMap, lookupFM, addToFM, emptyFM )
  67 import UniqFM           ( UniqFM, emptyUFM )
  68 import Unique           ( Unique )
  69 import BasicTypes       ( Unused )
  70 import Outputable
  71 import FastString       ( FastString )
  72
  73 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  74                           unsafeInterleaveIO, fixIO
  75                         )
  76
  77
  78 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{Types}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 type TcTyVar    = TyVar         -- Might be a mutable tyvar
  90 type TcTyVarSet = TyVarSet
  91
  92 type TcType = Type              -- A TcType can have mutable type variables
  93         -- Invariant on ForAllTy in TcTypes:
  94         --      forall a. T
  95         -- a cannot occur inside a MutTyVar in T; that is,
  96         -- T is "flattened" before quantifying over a
  97
  98 type TcPredType  = PredType
  99 type TcThetaType = ThetaType
 100 type TcRhoType   = RhoType
 101 type TcTauType   = TauType
 102 type TcKind      = TcType
 103 \end{code}
 104
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsection{The main monads: TcM, NF_TcM}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 \begin{code}
 113 type NF_TcM r =  TcDown -> TcEnv -> IO r        -- Can't raise UserError
 114 type TcM    r =  TcDown -> TcEnv -> IO r        -- Can raise UserError
 115         -- ToDo: nuke the 's' part
 116         -- The difference between the two is
 117         -- now for documentation purposes only
 118
 119 type Either_TcM r =  TcDown -> TcEnv -> IO r    -- Either NF_TcM or TcM
 120         -- Used only in this file for type signatures which
 121         -- have a part that's polymorphic in whether it's NF_TcM or TcM
 122         -- E.g. thenNF_Tc
 123
 124 type TcRef a = IORef a
 125 \end{code}
 126
 127 \begin{code}
 128
 129 initTc :: DynFlags
 130        -> TcEnv
 131        -> SrcLoc
 132        -> TcM r
 133        -> IO (Maybe r, (Bag ErrMsg, Bag WarnMsg))
 134
 135 initTc dflags tc_env src_loc do_this
 136   = do {
 137       us       <- mkSplitUniqSupply 'a' ;
 138       us_var   <- newIORef us ;
 139       dfun_var <- newIORef emptyFM ;
 140       errs_var <- newIORef (emptyBag,emptyBag) ;
 141       tvs_var  <- newIORef emptyUFM ;
 142
 143       let
 144           init_down = TcDown dflags [] us_var dfun_var
 145                              src_loc
 146                              [] errs_var
 147       ;
 148
 149       maybe_res <- catch (do {  res <- do_this init_down tc_env ;
 150                                 return (Just res)})
 151                          (\_ -> return Nothing) ;
 152
 153       (warns,errs) <- readIORef errs_var ;
 154       return (maybe_res, (warns, errs))
 155     }
 156
 157 -- Monadic operations
 158
 159 returnNF_Tc :: a -> NF_TcM a
 160 returnTc    :: a -> TcM a
 161 returnTc v down env = return v
 162
 163 thenTc    :: TcM a ->    (a -> TcM b)        -> TcM b
 164 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
 165 thenTc m k down env = do { r <- m down env; k r down env }
 166
 167 thenTc_    :: TcM a    -> TcM b        -> TcM b
 168 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
 169 thenTc_ m k down env = do { m down env; k down env }
 170
 171 listTc    :: [TcM a]    -> TcM [a]
 172 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
 173 listTc []     = returnTc []
 174 listTc (x:xs) = x                       `thenTc` \ r ->
 175                 listTc xs               `thenTc` \ rs ->
 176                 returnTc (r:rs)
 177
 178 mapTc    :: (a -> TcM b)    -> [a] -> TcM [b]
 179 mapTc_   :: (a -> TcM b)    -> [a] -> TcM ()
 180 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 181 mapTc f []     = returnTc []
 182 mapTc f (x:xs) = f x            `thenTc` \ r ->
 183                  mapTc f xs     `thenTc` \ rs ->
 184                  returnTc (r:rs)
 185 mapTc_ f xs = mapTc f xs  `thenTc_` returnTc ()
 186
 187
 188 foldrTc    :: (a -> b -> TcM b)    -> b -> [a] -> TcM b
 189 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
 190 foldrTc k z []     = returnTc z
 191 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 192                      k x r
 193
 194 foldlTc    :: (a -> b -> TcM a)    -> a -> [b] -> TcM a
 195 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
 196 foldlTc k z []     = returnTc z
 197 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 198                      foldlTc k r xs
 199
 200 mapAndUnzipTc    :: (a -> TcM (b,c))    -> [a]   -> TcM ([b],[c])
 201 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a]   -> NF_TcM ([b],[c])
 202 mapAndUnzipTc f []     = returnTc ([],[])
 203 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 204                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 205                          returnTc (r1:rs1, r2:rs2)
 206
 207 mapAndUnzip3Tc    :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
 208 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 209 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 210                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 211                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 212
 213 mapBagTc    :: (a -> TcM b)    -> Bag a -> TcM (Bag b)
 214 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
 215 mapBagTc f bag
 216   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 217                         b2 `thenTc` \ r2 ->
 218                         returnTc (unionBags r1 r2))
 219             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 220             (returnTc emptyBag)
 221             bag
 222
 223 fixTc    :: (a -> TcM a)    -> TcM a
 224 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
 225 fixTc m env down = fixIO (\ loop -> m loop env down)
 226
 227 recoverTc    :: TcM r -> TcM r -> TcM r
 228 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
 229 recoverTc recover m down env
 230   = catch (m down env) (\ _ -> recover down env)
 231
 232 returnNF_Tc      = returnTc
 233 thenNF_Tc        = thenTc
 234 thenNF_Tc_       = thenTc_
 235 fixNF_Tc         = fixTc
 236 recoverNF_Tc     = recoverTc
 237 mapNF_Tc         = mapTc
 238 foldrNF_Tc       = foldrTc
 239 foldlNF_Tc       = foldlTc
 240 listNF_Tc        = listTc
 241 mapAndUnzipNF_Tc = mapAndUnzipTc
 242 mapBagNF_Tc      = mapBagTc
 243 \end{code}
 244
 245 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 246 thread.  Ideally, this elegantly ensures that it can't zap any type
 247 variables that belong to the main thread.  But alas, the environment
 248 contains TyCon and Class environments that include TcKind stuff,
 249 which is a Royal Pain.  By the time this fork stuff is used they'll
 250 have been unified down so there won't be any kind variables, but we
 251 can't express that in the current typechecker framework.
 252
 253 So we compromise and use unsafeInterleaveSST.
 254
 255 We throw away any error messages!
 256
 257 \begin{code}
 258 forkNF_Tc :: NF_TcM r -> NF_TcM r
 259 forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
 260   = do
 261         -- Get a fresh unique supply
 262         us <- readIORef u_var
 263         let (us1, us2) = splitUniqSupply us
 264         writeIORef u_var us1
 265
 266         unsafeInterleaveIO (do {
 267                 us_var'  <- newIORef us2 ;
 268                 err_var' <- newIORef (emptyBag,emptyBag) ;
 269                 tv_var'  <- newIORef emptyUFM ;
 270                 let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
 271                 m down' env
 272                         -- ToDo: optionally dump any error messages
 273                 })
 274 \end{code}
 275
 276 \begin{code}
 277 traceTc :: SDoc -> NF_TcM ()
 278 traceTc doc down env = printErrs doc
 279
 280 ioToTc :: IO a -> NF_TcM a
 281 ioToTc io down env = io
 282 \end{code}
 283
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection{Error handling}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
 293 getErrsTc down env
 294   = readIORef (getTcErrs down)
 295
 296 failTc :: TcM a
 297 failTc down env = give_up
 298
 299 give_up :: IO a
 300 give_up = IOERROR (userError "Typecheck failed")
 301
 302 failWithTc :: Message -> TcM a                  -- Add an error message and fail
 303 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
 304
 305 addErrTc :: Message -> NF_TcM ()
 306 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
 307
 308 addErrsTc :: [Message] -> NF_TcM ()
 309 addErrsTc []       = returnNF_Tc ()
 310 addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs)  `thenNF_Tc_` returnNF_Tc ()
 311
 312 -- The 'M' variants do the TidyEnv bit
 313 failWithTcM :: (TidyEnv, Message) -> TcM a      -- Add an error message and fail
 314 failWithTcM env_and_msg
 315   = addErrTcM env_and_msg       `thenNF_Tc_`
 316     failTc
 317
 318 checkTc :: Bool -> Message -> TcM ()            -- Check that the boolean is true
 319 checkTc True  err = returnTc ()
 320 checkTc False err = failWithTc err
 321
 322 checkTcM :: Bool -> TcM () -> TcM ()    -- Check that the boolean is true
 323 checkTcM True  err = returnTc ()
 324 checkTcM False err = err
 325
 326 checkMaybeTc :: Maybe val -> Message -> TcM val
 327 checkMaybeTc (Just val) err = returnTc val
 328 checkMaybeTc Nothing    err = failWithTc err
 329
 330 checkMaybeTcM :: Maybe val -> TcM val -> TcM val
 331 checkMaybeTcM (Just val) err = returnTc val
 332 checkMaybeTcM Nothing    err = err
 333
 334 addErrTcM :: (TidyEnv, Message) -> NF_TcM ()    -- Add an error message but don't fail
 335 addErrTcM (tidy_env, err_msg) down env
 336   = add_err_tcm tidy_env err_msg ctxt loc down env
 337   where
 338     ctxt     = getErrCtxt down
 339     loc      = getLoc down
 340
 341 addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM ()     -- Add an error message but don't fail
 342 addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
 343   = add_err_tcm tidy_env err_msg full_ctxt loc down env
 344   where
 345     full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
 346
 347 add_err_tcm tidy_env err_msg ctxt loc down env
 348   = do
 349         (warns, errs) <- readIORef errs_var
 350         ctxt_msgs     <- do_ctxt tidy_env ctxt down env
 351         let err = addShortErrLocLine loc $
 352                   vcat (err_msg : ctxt_to_use ctxt_msgs)
 353         writeIORef errs_var (warns, errs `snocBag` err)
 354   where
 355     errs_var = getTcErrs down
 356
 357 do_ctxt tidy_env [] down env
 358   = return []
 359 do_ctxt tidy_env (c:cs) down env
 360   = do
 361         (tidy_env', m) <- c tidy_env down env
 362         ms             <- do_ctxt tidy_env' cs down env
 363         return (m:ms)
 364
 365 -- warnings don't have an 'M' variant
 366 warnTc :: Bool -> Message -> NF_TcM ()
 367 warnTc warn_if_true warn_msg down env
 368   | warn_if_true
 369   = do
 370         (warns,errs) <- readIORef errs_var
 371         ctxt_msgs    <- do_ctxt emptyTidyEnv ctxt down env
 372         let warn = addShortWarnLocLine loc $
 373                    vcat (warn_msg : ctxt_to_use ctxt_msgs)
 374         writeIORef errs_var (warns `snocBag` warn, errs)
 375   | otherwise
 376   = return ()
 377   where
 378     errs_var = getTcErrs down
 379     ctxt     = getErrCtxt down
 380     loc      = getLoc down
 381
 382 -- (tryTc r m) succeeds if m succeeds and generates no errors
 383 -- If m fails then r is invoked, passing the warnings and errors from m
 384 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
 385 --      (it might have recovered internally)
 386 --      If so, then r is invoked, passing the warnings and errors from m
 387
 388 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r)   -- Recovery action
 389       -> TcM r                          -- Thing to try
 390       -> TcM r
 391 tryTc recover main down env
 392   = do
 393         m_errs_var <- newIORef (emptyBag,emptyBag)
 394         catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
 395   where
 396     my_recover m_errs_var
 397       = do warns_and_errs <- readIORef m_errs_var
 398            recover warns_and_errs down env
 399
 400     my_main m_errs_var
 401        = do result <- main (setTcErrs down m_errs_var) env
 402
 403                 -- Check that m has no errors; if it has internal recovery
 404                 -- mechanisms it might "succeed" but having found a bunch of
 405                 -- errors along the way.
 406             (m_warns, m_errs) <- readIORef m_errs_var
 407             if isEmptyBag m_errs then
 408                 return result
 409               else
 410                 give_up         -- This triggers the catch
 411
 412
 413 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 414 -- If m fails then (checkNoErrsTc m) fails.
 415 -- If m succeeds, it checks whether m generated any errors messages
 416 --      (it might have recovered internally)
 417 --      If so, it fails too.
 418 -- Regardless, any errors generated by m are propagated to the enclosing context.
 419 checkNoErrsTc :: TcM r -> TcM r
 420 checkNoErrsTc main
 421   = tryTc my_recover main
 422   where
 423     my_recover (m_warns, m_errs) down env
 424         = do (warns, errs)     <- readIORef errs_var
 425              writeIORef errs_var (warns `unionBags` m_warns,
 426                                   errs  `unionBags` m_errs)
 427              give_up
 428         where
 429           errs_var = getTcErrs down
 430
 431
 432 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 433 -- otherwise it returns r.  Any error messages added by m are discarded,
 434 -- whether or not m succeeds.
 435 tryTc_ :: TcM r -> TcM r -> TcM r
 436 tryTc_ recover main
 437   = tryTc my_recover main
 438   where
 439     my_recover warns_and_errs = recover
 440
 441 -- (discardErrsTc m) runs m, but throw away all its error messages.
 442 discardErrsTc :: Either_TcM r -> Either_TcM r
 443 discardErrsTc main down env
 444   = do new_errs_var <- newIORef (emptyBag,emptyBag)
 445        main (setTcErrs down new_errs_var) env
 446 \end{code}
 447
 448
 449
 450 %************************************************************************
 451 %*                                                                      *
 452 \subsection{Mutable variables}
 453 %*                                                                      *
 454 %************************************************************************
 455
 456 \begin{code}
 457 tcNewMutVar :: a -> NF_TcM (TcRef a)
 458 tcNewMutVar val down env = newIORef val
 459
 460 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
 461 tcWriteMutVar var val down env = writeIORef var val
 462
 463 tcReadMutVar :: TcRef a -> NF_TcM a
 464 tcReadMutVar var down env = readIORef var
 465
 466 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
 467 tcNewMutTyVar name kind down env = newMutTyVar name kind
 468
 469 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
 470 tcNewSigTyVar name kind down env = newSigTyVar name kind
 471
 472 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 473 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 474
 475 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
 476 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482 \subsection{The environment}
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 \begin{code}
 487 tcGetEnv :: NF_TcM TcEnv
 488 tcGetEnv down env = return env
 489
 490 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
 491 tcSetEnv new_env m down old_env = m down new_env
 492 \end{code}
 493
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsection{Source location}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 \begin{code}
 502 tcGetDefaultTys :: NF_TcM [Type]
 503 tcGetDefaultTys down env = return (getDefaultTys down)
 504
 505 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
 506 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 507
 508 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
 509 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 510
 511 tcGetSrcLoc :: NF_TcM SrcLoc
 512 tcGetSrcLoc down env = return (getLoc down)
 513
 514 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
 515 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
 516
 517 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
 518                              -> TcM a -> TcM a
 519 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 520 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 521
 522 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
 523 -- Usual thing
 524 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 525 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 526 \end{code}
 527
 528
 529 %************************************************************************
 530 %*                                                                      *
 531 \subsection{Unique supply}
 532 %*                                                                      *
 533 %************************************************************************
 534
 535 \begin{code}
 536 tcGetUnique :: NF_TcM Unique
 537 tcGetUnique down env
 538   = do  uniq_supply <- readIORef u_var
 539         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 540             uniq                      = uniqFromSupply uniq_s
 541         writeIORef u_var new_uniq_supply
 542         return uniq
 543   where
 544     u_var = getUniqSupplyVar down
 545
 546 tcGetUniques :: Int -> NF_TcM [Unique]
 547 tcGetUniques n down env
 548   = do  uniq_supply <- readIORef u_var
 549         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 550             uniqs                     = uniqsFromSupply n uniq_s
 551         writeIORef u_var new_uniq_supply
 552         return uniqs
 553   where
 554     u_var = getUniqSupplyVar down
 555
 556 uniqSMToTcM :: UniqSM a -> NF_TcM a
 557 uniqSMToTcM m down env
 558   = do  uniq_supply <- readIORef u_var
 559         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 560         writeIORef u_var new_uniq_supply
 561         return (initUs_ uniq_s m)
 562   where
 563     u_var = getUniqSupplyVar down
 564 \end{code}
 565
 566
 567 \begin{code}
 568 tcGetDFunUniq :: String -> NF_TcM Int
 569 tcGetDFunUniq key down env
 570   = do dfun_supply <- readIORef d_var
 571        let uniq = case lookupFM dfun_supply key of
 572                       Just x  -> x+1
 573                       Nothing -> 0
 574        let dfun_supply' = addToFM dfun_supply key uniq
 575        writeIORef d_var dfun_supply'
 576        return uniq
 577   where
 578     d_var = getDFunSupplyVar down
 579 \end{code}
 580
 581
 582 %************************************************************************
 583 %*                                                                      *
 584 \subsection{TcDown}
 585 %*                                                                      *
 586 %************************************************************************
 587
 588 \begin{code}
 589 data TcDown
 590    = TcDown {
 591         tc_dflags :: DynFlags,
 592         tc_def    :: [Type],                    -- Types used for defaulting
 593
 594         tc_us     :: (TcRef UniqSupply),        -- Unique supply
 595         tc_ds     :: (TcRef DFunNameSupply),    -- Name supply for
 596                                                 -- dictionary function names
 597
 598         tc_loc    :: SrcLoc,                    -- Source location
 599         tc_ctxt   :: ErrCtxt,                   -- Error context
 600         tc_errs   :: (TcRef (Bag WarnMsg, Bag ErrMsg))
 601    }
 602
 603 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
 604                         -- Innermost first.  Monadic so that we have a chance
 605                         -- to deal with bound type variables just before error
 606                         -- message construction
 607
 608 type DFunNameSupply = FiniteMap String Int
 609         -- This is used as a name supply for dictionary functions
 610         -- From the inst decl we derive a string, usually by glomming together
 611         -- the class and tycon name -- but it doesn't matter exactly how;
 612         -- this map then gives a unique int for each inst decl with that
 613         -- string.  (In Haskell 98 there can only be one,
 614         -- but not so in more extended versions; also class CC type T
 615         -- and class C type TT might both give the string CCT
 616         --
 617         -- We could just use one Int for all the instance decls, but this
 618         -- way the uniques change less when you add an instance decl,
 619         -- hence less recompilation
 620 \end{code}
 621
 622 -- These selectors are *local* to TcMonad.lhs
 623
 624 \begin{code}
 625 getTcErrs (TcDown{tc_errs=errs}) = errs
 626 setTcErrs down errs = down{tc_errs=errs}
 627
 628 getDefaultTys (TcDown{tc_def=def}) = def
 629 setDefaultTys down def = down{tc_def=def}
 630
 631 getLoc (TcDown{tc_loc=loc}) = loc
 632 setLoc down loc = down{tc_loc=loc}
 633
 634 getUniqSupplyVar (TcDown{tc_us=us}) = us
 635 getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
 636
 637 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
 638 setErrCtxt down msg = down{tc_ctxt=[msg]}
 639 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 640
 641 doptsTc :: (DynFlags -> Bool) -> TcM Bool
 642 doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
 643    = return (dopt 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}