ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 module TcMonad(
   3         TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
   4         TcTyVar, TcTyVarSet, TcKind,
   5
   6         TcM, NF_TcM, TcDown, TcEnv,
   7
   8         initTc,
   9         returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
  10         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  11         mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
  12         traceTc, ioToTc,
  13
  14         uniqSMToTcM,
  15
  16         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
  17         fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
  18
  19         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  20
  21         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  22         failTc, failWithTc, addErrTc, addErrsTc, warnTc,
  23         recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
  24         addErrTcM, addInstErrTcM, failWithTcM,
  25
  26         tcGetEnv, tcSetEnv,
  27         tcGetDefaultTys, tcSetDefaultTys,
  28         tcGetUnique, tcGetUniques,
  29         doptsTc, getDOptsTc,
  30
  31         tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
  32         tcAddErrCtxtM, tcSetErrCtxtM,
  33         tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
  34
  35         tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
  36         tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
  37
  38         InstOrigin(..), InstLoc, pprInstLoc,
  39
  40         TcError, TcWarning, TidyEnv, emptyTidyEnv,
  41         arityErr
  42   ) where
  43
  44 #include "HsVersions.h"
  45
  46 import {-# SOURCE #-} TcEnv  ( TcEnv )
  47
  48 import HsLit            ( HsOverLit )
  49 import RnHsSyn          ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
  50 import TcType           ( Type, Kind, PredType, ThetaType, TauType, RhoType )
  51 import ErrUtils         ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
  52
  53 import Bag              ( Bag, emptyBag, isEmptyBag,
  54                           foldBag, unitBag, unionBags, snocBag )
  55 import Class            ( Class )
  56 import Name             ( Name )
  57 import Var              ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
  58 import VarEnv           ( TidyEnv, emptyTidyEnv )
  59 import VarSet           ( TyVarSet )
  60 import UniqSupply       ( UniqSupply, uniqFromSupply, uniqsFromSupply,
  61                           splitUniqSupply, mkSplitUniqSupply,
  62                           UniqSM, initUs_ )
  63 import SrcLoc           ( SrcLoc, noSrcLoc )
  64 import UniqFM           ( emptyUFM )
  65 import Unique           ( Unique )
  66 import CmdLineOpts
  67 import Outputable
  68
  69 import IOExts           ( IORef, newIORef, readIORef, writeIORef,
  70                           unsafeInterleaveIO, fixIO
  71                         )
  72
  73
  74 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  75 \end{code}
  76
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{Types}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 type TcTyVar    = TyVar         -- Might be a mutable tyvar
  86 type TcTyVarSet = TyVarSet
  87
  88 type TcType = Type              -- A TcType can have mutable type variables
  89         -- Invariant on ForAllTy in TcTypes:
  90         --      forall a. T
  91         -- a cannot occur inside a MutTyVar in T; that is,
  92         -- T is "flattened" before quantifying over a
  93
  94 type TcPredType     = PredType
  95 type TcThetaType    = ThetaType
  96 type TcRhoType      = RhoType
  97 type TcTauType      = TauType
  98 type TcKind         = TcType
  99 \end{code}
 100
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection{The main monads: TcM, NF_TcM}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 \begin{code}
 109 type NF_TcM r =  TcDown -> TcEnv -> IO r        -- Can't raise UserError
 110 type TcM    r =  TcDown -> TcEnv -> IO r        -- Can raise UserError
 111
 112 type Either_TcM r =  TcDown -> TcEnv -> IO r    -- Either NF_TcM or TcM
 113         -- Used only in this file for type signatures which
 114         -- have a part that's polymorphic in whether it's NF_TcM or TcM
 115         -- E.g. thenNF_Tc
 116
 117 type TcRef a = IORef a
 118 \end{code}
 119
 120 \begin{code}
 121
 122 initTc :: DynFlags
 123        -> TcEnv
 124        -> TcM r
 125        -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
 126
 127 initTc dflags tc_env do_this
 128   = do {
 129       us       <- mkSplitUniqSupply 'a' ;
 130       us_var   <- newIORef us ;
 131       errs_var <- newIORef (emptyBag,emptyBag) ;
 132       tvs_var  <- newIORef emptyUFM ;
 133
 134       let
 135           init_down = TcDown { tc_dflags = dflags, tc_def = [],
 136                                tc_us = us_var, tc_loc = noSrcLoc,
 137                                tc_ctxt = [], tc_errs = errs_var }
 138       ;
 139
 140       maybe_res <- catch (do {  res <- do_this init_down tc_env ;
 141                                 return (Just res)})
 142                          (\_ -> return Nothing) ;
 143
 144       (warns,errs) <- readIORef errs_var ;
 145       return (maybe_res, (warns, errs))
 146     }
 147
 148 -- Monadic operations
 149
 150 returnNF_Tc :: a -> NF_TcM a
 151 returnTc    :: a -> TcM a
 152 returnTc v down env = return v
 153
 154 thenTc    :: TcM a ->    (a -> TcM b)        -> TcM b
 155 thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
 156 thenTc m k down env = do { r <- m down env; k r down env }
 157
 158 thenTc_    :: TcM a    -> TcM b        -> TcM b
 159 thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
 160 thenTc_ m k down env = do { m down env; k down env }
 161
 162 listTc    :: [TcM a]    -> TcM [a]
 163 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
 164 listTc []     = returnTc []
 165 listTc (x:xs) = x                       `thenTc` \ r ->
 166                 listTc xs               `thenTc` \ rs ->
 167                 returnTc (r:rs)
 168
 169 mapTc    :: (a -> TcM b)    -> [a] -> TcM [b]
 170 mapTc_   :: (a -> TcM b)    -> [a] -> TcM ()
 171 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 172 mapTc f []     = returnTc []
 173 mapTc f (x:xs) = f x            `thenTc` \ r ->
 174                  mapTc f xs     `thenTc` \ rs ->
 175                  returnTc (r:rs)
 176 mapTc_ f xs = mapTc f xs  `thenTc_` returnTc ()
 177
 178
 179 foldrTc    :: (a -> b -> TcM b)    -> b -> [a] -> TcM b
 180 foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
 181 foldrTc k z []     = returnTc z
 182 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 183                      k x r
 184
 185 foldlTc    :: (a -> b -> TcM a)    -> a -> [b] -> TcM a
 186 foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
 187 foldlTc k z []     = returnTc z
 188 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 189                      foldlTc k r xs
 190
 191 mapAndUnzipTc    :: (a -> TcM (b,c))    -> [a]   -> TcM ([b],[c])
 192 mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a]   -> NF_TcM ([b],[c])
 193 mapAndUnzipTc f []     = returnTc ([],[])
 194 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 195                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 196                          returnTc (r1:rs1, r2:rs2)
 197
 198 mapAndUnzip3Tc    :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
 199 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 200 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 201                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 202                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 203
 204 mapBagTc    :: (a -> TcM b)    -> Bag a -> TcM (Bag b)
 205 mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
 206 mapBagTc f bag
 207   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 208                         b2 `thenTc` \ r2 ->
 209                         returnTc (unionBags r1 r2))
 210             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 211             (returnTc emptyBag)
 212             bag
 213
 214 fixTc    :: (a -> TcM a)    -> TcM a
 215 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
 216 fixTc m env down = fixIO (\ loop -> m loop env down)
 217 {-# NOINLINE fixTc #-}
 218 -- aargh!  Not inlining fixTc alleviates a space leak problem.
 219 -- Normally fixTc is used with a lazy tuple match: if the optimiser is
 220 -- shown the definition of fixTc, it occasionally transforms the code
 221 -- in such a way that the code generator doesn't spot the selector
 222 -- thunks.  Sigh.
 223
 224 recoverTc    :: TcM r -> TcM r -> TcM r
 225 recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
 226 recoverTc recover m down env
 227   = catch (m down env) (\ _ -> recover down env)
 228
 229 returnNF_Tc      = returnTc
 230 thenNF_Tc        = thenTc
 231 thenNF_Tc_       = thenTc_
 232 fixNF_Tc         = fixTc
 233 recoverNF_Tc     = recoverTc
 234 mapNF_Tc         = mapTc
 235 foldrNF_Tc       = foldrTc
 236 foldlNF_Tc       = foldlTc
 237 listNF_Tc        = listTc
 238 mapAndUnzipNF_Tc = mapAndUnzipTc
 239 mapBagNF_Tc      = mapBagTc
 240 \end{code}
 241
 242 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 243 thread.  Ideally, this elegantly ensures that it can't zap any type
 244 variables that belong to the main thread.  But alas, the environment
 245 contains TyCon and Class environments that include TcKind stuff,
 246 which is a Royal Pain.  By the time this fork stuff is used they'll
 247 have been unified down so there won't be any kind variables, but we
 248 can't express that in the current typechecker framework.
 249
 250 So we compromise and use unsafeInterleaveIO.
 251
 252 We throw away any error messages!
 253
 254 \begin{code}
 255 forkNF_Tc :: NF_TcM r -> NF_TcM r
 256 forkNF_Tc m down@(TcDown { tc_us = u_var }) env
 257   = do
 258         -- Get a fresh unique supply
 259         us <- readIORef u_var
 260         let (us1, us2) = splitUniqSupply us
 261         writeIORef u_var us1
 262
 263         unsafeInterleaveIO (do {
 264                 us_var'  <- newIORef us2 ;
 265                 err_var' <- newIORef (emptyBag,emptyBag) ;
 266                 let { down' = down { tc_us = us_var', tc_errs = err_var' } };
 267                 m down' env
 268                         -- ToDo: optionally dump any error messages
 269                 })
 270 \end{code}
 271
 272 \begin{code}
 273 traceTc :: SDoc -> NF_TcM ()
 274 traceTc doc (TcDown { tc_dflags=dflags }) env
 275   | dopt Opt_D_dump_tc_trace dflags = printDump doc
 276   | otherwise                       = return ()
 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     errs_var = getTcErrs down
 395
 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                 -- No errors, so return normally, but don't lose the warnings
 409                 if isEmptyBag m_warns then
 410                    return result
 411                 else
 412                    do (warns, errs) <- readIORef errs_var
 413                       writeIORef errs_var (warns `unionBags` m_warns, errs)
 414                       return result
 415               else
 416                 give_up         -- This triggers the catch
 417
 418
 419 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
 420 -- If m fails then (checkNoErrsTc m) fails.
 421 -- If m succeeds, it checks whether m generated any errors messages
 422 --      (it might have recovered internally)
 423 --      If so, it fails too.
 424 -- Regardless, any errors generated by m are propagated to the enclosing context.
 425 checkNoErrsTc :: TcM r -> TcM r
 426 checkNoErrsTc main
 427   = tryTc my_recover main
 428   where
 429     my_recover (m_warns, m_errs) down env
 430         = do (warns, errs)     <- readIORef errs_var
 431              writeIORef errs_var (warns `unionBags` m_warns,
 432                                   errs  `unionBags` m_errs)
 433              give_up
 434         where
 435           errs_var = getTcErrs down
 436
 437
 438 -- (tryTc_ r m) tries m; if it succeeds it returns it,
 439 -- otherwise it returns r.  Any error messages added by m are discarded,
 440 -- whether or not m succeeds.
 441 tryTc_ :: TcM r -> TcM r -> TcM r
 442 tryTc_ recover main
 443   = tryTc my_recover main
 444   where
 445     my_recover warns_and_errs = recover
 446
 447 -- (discardErrsTc m) runs m, but throw away all its error messages.
 448 discardErrsTc :: Either_TcM r -> Either_TcM r
 449 discardErrsTc main down env
 450   = do new_errs_var <- newIORef (emptyBag,emptyBag)
 451        main (setTcErrs down new_errs_var) env
 452 \end{code}
 453
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458 \subsection{Mutable variables}
 459 %*                                                                      *
 460 %************************************************************************
 461
 462 \begin{code}
 463 tcNewMutVar :: a -> NF_TcM (TcRef a)
 464 tcNewMutVar val down env = newIORef val
 465
 466 tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
 467 tcWriteMutVar var val down env = writeIORef var val
 468
 469 tcReadMutVar :: TcRef a -> NF_TcM a
 470 tcReadMutVar var down env = readIORef var
 471
 472 tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
 473 tcNewMutTyVar name kind down env = newMutTyVar name kind
 474
 475 tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
 476 tcNewSigTyVar name kind down env = newSigTyVar name kind
 477
 478 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 479 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
 480
 481 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
 482 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
 483 \end{code}
 484
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection{The environment}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 \begin{code}
 493 tcGetEnv :: NF_TcM TcEnv
 494 tcGetEnv down env = return env
 495
 496 tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
 497 tcSetEnv new_env m down old_env = m down new_env
 498 \end{code}
 499
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsection{Source location}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 \begin{code}
 508 tcGetDefaultTys :: NF_TcM [Type]
 509 tcGetDefaultTys down env = return (getDefaultTys down)
 510
 511 tcSetDefaultTys :: [Type] -> TcM r -> TcM r
 512 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 513
 514 tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
 515 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 516
 517 tcGetSrcLoc :: NF_TcM SrcLoc
 518 tcGetSrcLoc down env = return (getLoc down)
 519
 520 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
 521 tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
 522
 523 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
 524                              -> TcM a -> TcM a
 525 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 526 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 527
 528 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
 529 -- Usual thing
 530 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 531 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 532
 533 tcPopErrCtxt :: Either_TcM r -> Either_TcM  r
 534 tcPopErrCtxt m down env = m (popErrCtxt down) env
 535 \end{code}
 536
 537
 538 %************************************************************************
 539 %*                                                                      *
 540 \subsection{Unique supply}
 541 %*                                                                      *
 542 %************************************************************************
 543
 544 \begin{code}
 545 tcGetUnique :: NF_TcM Unique
 546 tcGetUnique down env
 547   = do  uniq_supply <- readIORef u_var
 548         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 549             uniq                      = uniqFromSupply uniq_s
 550         writeIORef u_var new_uniq_supply
 551         return uniq
 552   where
 553     u_var = getUniqSupplyVar down
 554
 555 tcGetUniques :: NF_TcM [Unique]
 556 tcGetUniques down env
 557   = do  uniq_supply <- readIORef u_var
 558         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 559             uniqs                     = uniqsFromSupply uniq_s
 560         writeIORef u_var new_uniq_supply
 561         return uniqs
 562   where
 563     u_var = getUniqSupplyVar down
 564
 565 uniqSMToTcM :: UniqSM a -> NF_TcM a
 566 uniqSMToTcM m down env
 567   = do  uniq_supply <- readIORef u_var
 568         let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 569         writeIORef u_var new_uniq_supply
 570         return (initUs_ uniq_s m)
 571   where
 572     u_var = getUniqSupplyVar down
 573 \end{code}
 574
 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         tc_us     :: (TcRef UniqSupply),        -- Unique supply
 589         tc_loc    :: SrcLoc,                    -- Source location
 590         tc_ctxt   :: ErrCtxt,                   -- Error context
 591         tc_errs   :: (TcRef (Bag WarnMsg, Bag ErrMsg))
 592    }
 593
 594 type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
 595                         -- Innermost first.  Monadic so that we have a chance
 596                         -- to deal with bound type variables just before error
 597                         -- message construction
 598 \end{code}
 599
 600 -- These selectors are *local* to TcMonad.lhs
 601
 602 \begin{code}
 603 getTcErrs (TcDown{tc_errs=errs}) = errs
 604 setTcErrs down errs = down{tc_errs=errs}
 605
 606 getDefaultTys (TcDown{tc_def=def}) = def
 607 setDefaultTys down def = down{tc_def=def}
 608
 609 getLoc (TcDown{tc_loc=loc}) = loc
 610 setLoc down loc = down{tc_loc=loc}
 611
 612 getUniqSupplyVar (TcDown{tc_us=us}) = us
 613
 614 getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
 615 setErrCtxt down msg = down{tc_ctxt=[msg]}
 616 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 617
 618 popErrCtxt down = case tc_ctxt down of
 619                         []     -> down
 620                         m : ms -> down{tc_ctxt = ms}
 621
 622 doptsTc :: DynFlag -> TcM Bool
 623 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
 624    = return (dopt dflag dflags)
 625
 626 getDOptsTc :: TcM DynFlags
 627 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
 628    = return dflags
 629 \end{code}
 630
 631
 632
 633
 634 %************************************************************************
 635 %*                                                                      *
 636 \subsection{TypeChecking Errors}
 637 %*                                                                      *
 638 %************************************************************************
 639
 640 \begin{code}
 641 type TcError   = Message
 642 type TcWarning = Message
 643
 644 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 645                  | otherwise          = takeAtMost 3 ctxt
 646                  where
 647                    takeAtMost :: Int -> [a] -> [a]
 648                    takeAtMost 0 ls = []
 649                    takeAtMost n [] = []
 650                    takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
 651
 652 arityErr kind name n m
 653   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
 654            n_arguments <> comma, text "but has been given", int m]
 655     where
 656         n_arguments | n == 0 = ptext SLIT("no arguments")
 657                     | n == 1 = ptext SLIT("1 argument")
 658                     | True   = hsep [int n, ptext SLIT("arguments")]
 659 \end{code}
 660
 661
 662
 663 %************************************************************************
 664 %*                                                                      *
 665 \subsection[Inst-origin]{The @InstOrigin@ type}
 666 %*                                                                      *
 667 %************************************************************************
 668
 669 The @InstOrigin@ type gives information about where a dictionary came from.
 670 This is important for decent error message reporting because dictionaries
 671 don't appear in the original source code.  Doubtless this type will evolve...
 672
 673 It appears in TcMonad because there are a couple of error-message-generation
 674 functions that deal with it.
 675
 676 \begin{code}
 677 type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 678
 679 data InstOrigin
 680   = OccurrenceOf Id             -- Occurrence of an overloaded identifier
 681
 682   | IPOcc Name                  -- Occurrence of an implicit parameter
 683   | IPBind Name                 -- Binding site of an implicit parameter
 684
 685   | RecordUpdOrigin
 686
 687   | DataDeclOrigin              -- Typechecking a data declaration
 688
 689   | InstanceDeclOrigin          -- Typechecking an instance decl
 690
 691   | LiteralOrigin HsOverLit     -- Occurrence of a literal
 692
 693   | PatOrigin RenamedPat
 694
 695   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
 696
 697   | SignatureOrigin             -- A dict created from a type signature
 698   | Rank2Origin                 -- A dict created when typechecking the argument
 699                                 -- of a rank-2 typed function
 700
 701   | DoOrigin                    -- The monad for a do expression
 702
 703   | ClassDeclOrigin             -- Manufactured during a class decl
 704
 705   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 706                         Type
 707
 708         -- When specialising instances the instance info attached to
 709         -- each class is not yet ready, so we record it inside the
 710         -- origin information.  This is a bit of a hack, but it works
 711         -- fine.  (Patrick is to blame [WDP].)
 712
 713   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 714
 715         -- Argument or result of a ccall
 716         -- Dictionaries with this origin aren't actually mentioned in the
 717         -- translated term, and so need not be bound.  Nor should they
 718         -- be abstracted over.
 719
 720   | CCallOrigin         String                  -- CCall label
 721                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 722                                                 -- Just arg, for an argument
 723
 724   | LitLitOrigin        String  -- the litlit
 725
 726   | UnknownOrigin       -- Help! I give up...
 727 \end{code}
 728
 729 \begin{code}
 730 pprInstLoc :: InstLoc -> SDoc
 731 pprInstLoc (orig, locn, ctxt)
 732   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 733   where
 734     pp_orig (OccurrenceOf id)
 735         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 736     pp_orig (IPOcc name)
 737         = hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
 738     pp_orig (IPBind name)
 739         = hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
 740     pp_orig (LiteralOrigin lit)
 741         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 742     pp_orig (PatOrigin pat)
 743         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 744     pp_orig (InstanceDeclOrigin)
 745         =  ptext SLIT("the instance declaration")
 746     pp_orig (ArithSeqOrigin seq)
 747         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 748     pp_orig (SignatureOrigin)
 749         =  ptext SLIT("a type signature")
 750     pp_orig (Rank2Origin)
 751         =  ptext SLIT("a function with an overloaded argument type")
 752     pp_orig (DoOrigin)
 753         =  ptext SLIT("a do statement")
 754     pp_orig (ClassDeclOrigin)
 755         =  ptext SLIT("a class declaration")
 756     pp_orig (InstanceSpecOrigin clas ty)
 757         = hsep [text "a SPECIALIZE instance pragma; class",
 758                 quotes (ppr clas), text "type:", ppr ty]
 759     pp_orig (ValSpecOrigin name)
 760         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 761     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 762         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 763     pp_orig (CCallOrigin clabel (Just arg_expr))
 764         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 765                 text "namely", quotes (ppr arg_expr)]
 766     pp_orig (LitLitOrigin s)
 767         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 768     pp_orig (UnknownOrigin)
 769         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 770 \end{code}