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