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