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