ghc/compiler/typecheck/TcMonad.lhs

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