ghc/compiler/typecheck/TcMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcMonad]{@TcMonad@: monad machinery for the typechecker}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcMonad (
  10         TcM(..), TcResult{-abstract-},
  11         thenTc, thenTc_, returnTc, failTc, checkTc,
  12         listTc, mapTc, mapAndUnzipTc,
  13         fixTc, foldlTc, initTc,
  14         recoverTc, recoverQuietlyTc,
  15
  16         NF_TcM(..),
  17         thenNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
  18         fixNF_Tc, noFailTc,
  19
  20         Baby_TcM(..), Baby_TcResult{-abstract-},
  21         returnB_Tc, thenB_Tc, thenB_Tc_,
  22         failB_Tc, recoverIgnoreErrorsB_Tc,
  23         fixB_Tc, mapB_Tc,
  24         babyTcMtoTcM, babyTcMtoNF_TcM,
  25         getUniqueB_Tc, getUniquesB_Tc,
  26         addSrcLocB_Tc, getSrcLocB_Tc,
  27         getSwitchCheckerB_Tc, checkB_Tc,
  28         uniqSMtoBabyTcM,
  29
  30         getSwitchCheckerTc,
  31         getDefaultingTys, setDefaultingTys,
  32         getUniquesTc, getUniqueTc,
  33         rn4MtoTcM,
  34
  35         getTyVarUniquesTc, getTyVarUniqueTc,
  36
  37         applyTcSubstToTy, applyTcSubstToTys,
  38 --UNUSED:       applyTcSubstToThetaTy,
  39         applyTcSubstToTyVar, applyTcSubstToTyVars,
  40         applyTcSubstToId,
  41         applyTcSubstToInst, applyTcSubstToInsts,
  42         extendSubstTc, pruneSubstTc,
  43
  44         addSrcLocTc, getSrcLocTc,
  45         checkMaybeTc,    checkMaybesTc,
  46         checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc,
  47
  48         lookupInst_Tc, lookupNoBindInst_Tc,
  49
  50         -- and to make the interface self-sufficient ...
  51         UniqueSupply, SplitUniqSupply,
  52         Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..),
  53         PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon,
  54         Class, UniType, TauType(..), ThetaType(..), SigmaType(..),
  55         UnifyErrContext, Unique, Expr,
  56         TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst,
  57         GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..),
  58         GlobalNameFun(..), Name, ProtoName
  59
  60         IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques)
  61         IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily)
  62         IF_ATTACK_PRAGMAS(COMMA applySubstToId)
  63         IF_ATTACK_PRAGMAS(COMMA applySubstToInst)
  64         IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy)
  65         IF_ATTACK_PRAGMAS(COMMA applySubstToTy)
  66         IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar)
  67     ) where
  68
  69 import AbsSyn
  70 import AbsUniType       ( TyVar, TyVarTemplate, TyCon, Class, UniType,
  71                           TauType(..), ThetaType(..), SigmaType(..)
  72                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  73                         )
  74 import Bag              ( Bag, snocBag, emptyBag, isEmptyBag )
  75 import CmdLineOpts      ( GlobalSwitch )
  76 import Errors           ( noInstanceErr, unifyErr, pprBagOfErrors,
  77                           Error(..), UnifyErrInfo(..), UnifyErrContext(..)
  78                         )
  79 import FiniteMap        ( emptyFM, FiniteMap )
  80 import Id               ( applySubstToId )
  81 import Inst             ( applySubstToInst )
  82 import InstEnv          ( lookupInst, lookupNoBindInst, Inst )
  83 import Maybes           ( Maybe(..), MaybeErr(..) )
  84 import Pretty
  85 import RenameMonad4     ( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) )
  86 import SrcLoc           ( mkUnknownSrcLoc )
  87 import Subst
  88 import Unify
  89 import SplitUniq
  90 import Unique
  91 import Util
  92
  93 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection[TcM-TcM]{Plain @TcM@ monadery}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 The following @TcM@ is of the garden variety which can fail, and does
 103 as soon as possible.
 104
 105 \begin{code}
 106 -- internal use only...
 107 type InTcM output
 108         =  (GlobalSwitch -> Bool)       -- so we can chk cmd-line switches
 109         -> [UniType]                    -- types used for defaulting; down only
 110         -> Subst                        -- substitution; threaded
 111         -> SplitUniqSupply              -- threaded
 112         -> Bag Error                    -- threaded
 113         -> SrcLoc                       -- only passed downwards
 114         -> output
 115
 116 data TcResult result
 117   = TcSucceeded result
 118                 Subst
 119                 (Bag Error)
 120   | TcFailed    Subst
 121                 (Bag Error)
 122
 123 type TcM result
 124         = InTcM (TcResult result)
 125
 126 #ifdef __GLASGOW_HASKELL__
 127 {-# INLINE thenTc #-}
 128 {-# INLINE thenTc_ #-}
 129 {-# INLINE returnTc #-}
 130 #endif
 131
 132 thenTc  :: TcM a -> (a -> TcM b) -> TcM b
 133 thenTc_ :: TcM a -> TcM b -> TcM b
 134
 135 thenTc expr cont sw_chkr dtys subst us errs src_loc
 136   = case splitUniqSupply us         of { (s1, s2) ->
 137     case (expr sw_chkr dtys subst s1 errs src_loc) of
 138       TcFailed subst errs -> TcFailed subst errs
 139       TcSucceeded result subst2 errs2
 140         -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
 141     }
 142
 143 thenTc_ expr cont sw_chkr dtys subst us errs src_loc
 144   = case splitUniqSupply us         of { (s1, s2) ->
 145     case (expr sw_chkr dtys subst s1 errs src_loc) of
 146       TcFailed subst errs -> TcFailed subst errs
 147       TcSucceeded _ subst2 errs2
 148         -> cont sw_chkr dtys subst2 s2 errs2 src_loc
 149     }
 150
 151 returnTc :: a -> TcM a
 152 returnTc result sw_chkr dtys subst us errs src_loc
 153   = TcSucceeded result subst errs
 154
 155 failTc err sw_chkr dtys subst us errs src_loc
 156   = TcFailed subst (errs `snocBag` err)
 157 \end{code}
 158
 159 @recoverTc@ recovers from an error, by providing a value to use
 160 instead.  It is also lazy, in that it always succeeds immediately; the
 161 thing inside is only even looked at when you pull on the errors, or on
 162 the value returned.
 163
 164 @recoverQuietlyTc@ doesn't even report the errors found---it is used
 165 when looking at pragmas.
 166
 167 \begin{code}
 168 recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a
 169
 170 recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
 171   = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
 172       TcSucceeded result subst_out errs_out ->
 173         (result, combineSubstUndos subst_out, errs_out)
 174
 175       TcFailed subst_out errs_out ->
 176         (use_this_if_err, undoSubstUndos subst_out, errs_out)
 177           -- Note that we return the *undone* substitution
 178           -- and the *incoming* UniqueSupply
 179
 180 recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
 181   = (r2, s2, e2)
 182   where
 183     (r2, s2, e2)
 184       = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
 185           TcSucceeded result subst_out errs_out ->
 186             (result, combineSubstUndos subst_out, errs_out)
 187
 188           TcFailed subst_out errs_out ->
 189             (use_this_if_err, undoSubstUndos subst_out, errs_in)
 190           -- Note that we return the *undone* substitution,
 191           -- the *incoming* UniqueSupply, and the *incoming* errors
 192 \end{code}
 193
 194 The following @TcM@ checks a condition and fails with the given error
 195 message.
 196
 197 \begin{code}
 198 checkTc :: Bool -> Error -> TcM ()
 199
 200 checkTc True  err = failTc err
 201 checkTc False err = returnTc ()
 202
 203 listTc :: [TcM a] -> TcM [a]
 204
 205 listTc [] = returnTc []
 206 listTc (x:xs)
 207  = x            `thenTc` \ r ->
 208    listTc xs    `thenTc` \ rs ->
 209    returnTc (r:rs)
 210
 211 mapTc :: (a -> TcM b) -> [a] -> TcM [b]
 212 mapTc f [] = returnTc []
 213 mapTc f (x:xs)
 214  = f x          `thenTc` \ r ->
 215    mapTc f xs   `thenTc` \ rs ->
 216    returnTc (r:rs)
 217
 218 mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c])
 219
 220 mapAndUnzipTc f [] = returnTc ([], [])
 221 mapAndUnzipTc f (x:xs)
 222  = f x                  `thenTc` \ (r1,  r2)  ->
 223    mapAndUnzipTc f xs   `thenTc` \ (rs1, rs2) ->
 224    returnTc (r1:rs1, r2:rs2)
 225
 226 foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
 227 foldlTc f a []     = returnTc a
 228 foldlTc f a (b:bs) = f a b      `thenTc` \ a2 ->
 229                      foldlTc f a2 bs
 230
 231 fixTc :: (x -> TcM x) -> TcM x
 232 fixTc m sw_chkr dtys subst us errs src_loc
 233   = lim
 234   where
 235     lim    = m result sw_chkr dtys subst us errs src_loc
 236     result = case lim of
 237                TcSucceeded result _ _ -> result
 238 #ifdef DEBUG
 239                TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs)
 240 #endif
 241 \end{code}
 242
 243 And the machinery to start things up:
 244
 245 \begin{code}
 246 aRRAY_SIZE :: Int
 247 aRRAY_SIZE  = 511
 248
 249 initTc  :: (GlobalSwitch -> Bool)
 250         -> SplitUniqSupply
 251         -> TcM result
 252         -> MaybeErr result (Bag Error)
 253
 254 initTc sw_chkr us tc
 255   = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of
 256       TcFailed _ errs -> Failed errs
 257       TcSucceeded result subst2 errs
 258         -> if isEmptyBag errs then
 259               Succeeded result
 260            else
 261               Failed errs
 262
 263 init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 This is a no-fail version of a TcM.
 274
 275 \begin{code}
 276 -- ToDo: re-order fields to match TcM?
 277 type NF_TcM result = InTcM (result, Subst, Bag Error)
 278
 279 #ifdef __GLASGOW_HASKELL__
 280 {-# INLINE thenNF_Tc #-}
 281 {-# INLINE returnNF_Tc #-}
 282 #endif
 283
 284 thenNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
 285 \end{code}
 286
 287 In particular, @thenNF_Tc@ has all of these types:
 288 \begin{pseudocode}
 289 thenNF_Tc :: NF_TcM a -> (a -> TcM b)    -> TcM b
 290 thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
 291 \end{pseudocode}
 292
 293 \begin{code}
 294 thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
 295   = case splitUniqSupply us         of { (s1, s2) ->
 296     case (expr sw_chkr dtys subst s1 errs src_loc) of
 297      (result, subst2, errs2)
 298        -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
 299     }
 300
 301 returnNF_Tc :: a -> NF_TcM a
 302 returnNF_Tc result sw_chkr dtys subst us errs src_loc
 303   = (result, subst, errs)
 304
 305 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
 306 listNF_Tc [] = returnNF_Tc []
 307 listNF_Tc (x:xs)
 308   = x                   `thenNF_Tc` \ r ->
 309     listNF_Tc xs        `thenNF_Tc` \ rs ->
 310     returnNF_Tc (r:rs)
 311
 312 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 313 mapNF_Tc f [] = returnNF_Tc []
 314 mapNF_Tc f (x:xs)
 315   = f x                 `thenNF_Tc` \ r ->
 316     mapNF_Tc f xs       `thenNF_Tc` \ rs ->
 317     returnNF_Tc (r:rs)
 318
 319 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
 320 fixNF_Tc m sw_chkr dtys subst us errs src_loc
 321   = lim
 322   where
 323     lim = m result sw_chkr dtys subst us errs src_loc
 324     (result, _, _) = lim
 325 \end{code}
 326
 327 @noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}.  You use it
 328 when you are darn sure that the TcM won't actually fail!
 329
 330 \begin{code}
 331 noFailTc :: TcM a -> NF_TcM a
 332
 333 noFailTc expr sw_chkr dtys subst us errs src_loc
 334   = case (expr sw_chkr dtys subst us errs src_loc) of
 335       TcFailed _ _ -> panic "Failure in noFailTc!"
 336       TcSucceeded result subst errs
 337         -> (result, subst, errs)
 338 \end{code}
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 These functions extract uniques from the monad. There are two unique
 347 supplies embedded in the monad.
 348 \begin{itemize}
 349 \item
 350 normal unique supply
 351 \item
 352 special unique supply for TyVars (these index the substitution)
 353 \end{itemize}
 354
 355 \begin{code}
 356 getUniquesTc :: Int -> NF_TcM [Unique]
 357 getUniquesTc n sw_chkr dtys subst us errs src_loc
 358   = case (getSUniques n us) of { uniques ->
 359     (uniques, subst, errs) }
 360
 361 -- This simpler version is often adequate:
 362
 363 getUniqueTc :: NF_TcM Unique
 364 getUniqueTc sw_chkr dtys subst us errs src_loc
 365   = case (getSUnique us) of { unique ->
 366     (unique, subst, errs) }
 367
 368 rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
 369
 370 rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
 371   = let
 372         (rn_result, rn_errs)
 373           = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
 374             -- laziness may be good for you (see below)
 375     in
 376     ((rn_result, rn_errs), subst, errs)
 377
 378 -- Special uniques for TyVars extracted from the substitution
 379
 380 getTyVarUniquesTc :: Int -> NF_TcM [Unique]
 381 getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
 382   = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
 383   where
 384     (subst2, uniques) = getSubstTyVarUniques n subst
 385
 386 getTyVarUniqueTc :: NF_TcM Unique
 387 getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
 388   = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
 389   where
 390     (subst2, unique) = getSubstTyVarUnique subst
 391 \end{code}
 392
 393 %************************************************************************
 394 %*                                                                      *
 395 \subsection[TcM-extract]{Extractings other things from the monad}
 396 %*                                                                      *
 397 %************************************************************************
 398
 399 These are functions which extract things from the monad.
 400
 401 Extending and applying the substitution.
 402
 403 ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
 404 a number of places where only the sequenced substitution is required.
 405 A lighter weight sequence substitution monad would be more appropriate
 406 with TcMonad interface functions defined here.
 407
 408 \begin{code}
 409 getTcSubst            ::              NF_TcM Subst
 410 applyTcSubstToTy      :: TauType   -> NF_TcM TauType
 411 --UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType
 412 applyTcSubstToTyVar   :: TyVar     -> NF_TcM TauType
 413 applyTcSubstToId      :: Id        -> NF_TcM Id
 414 applyTcSubstToInst    :: Inst      -> NF_TcM Inst
 415
 416 getTcSubst sw_chkr dtys subst us errs src_loc
 417   = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
 418
 419 applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
 420   = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
 421     returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
 422     }
 423
 424 {- UNUSED:
 425 applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
 426   = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
 427     returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
 428     }
 429 -}
 430
 431 applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
 432   = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
 433     returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
 434     }
 435
 436 applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
 437   = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
 438     returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
 439     }
 440
 441 applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
 442   = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
 443     returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
 444     }
 445
 446 applyTcSubstToTyVars :: [TyVar]   -> NF_TcM [UniType]
 447 applyTcSubstToTys    :: [TauType] -> NF_TcM [TauType]
 448
 449 applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
 450 applyTcSubstToTys    tys    = mapNF_Tc applyTcSubstToTy    tys
 451 applyTcSubstToInsts  insts  = mapNF_Tc applyTcSubstToInst  insts
 452 \end{code}
 453
 454 \begin{code}
 455 extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
 456
 457 extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
 458   = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
 459     case extend_result of
 460       SubstOK ->
 461         TcSucceeded () new_subst errs
 462
 463       OccursCheck tyvar ty ->
 464         TcFailed new_subst
 465                  (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
 466
 467       AlreadyBound ty1 ->
 468             -- This should only happen in the case of a call to
 469             -- extendSubstTc from the unifier!  The way things are now
 470             -- we can't check for the AlreadyBound case in other calls
 471             -- to extendSubstTc, but we're confident it never shows up.
 472             -- Ugh!
 473         unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
 474     }
 475 \end{code}
 476
 477
 478 @pruneSubstTc@ does nothing with an array substitution implementation!!!
 479 \begin{code}
 480 pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
 481              -> TcM a   -- Type-check this
 482              -> TcM a   -- Return same result but pruned subst
 483
 484 pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
 485   = m sw_chkr dtys subst uniqs errs src_loc
 486 \end{code}
 487
 488 \begin{code}
 489 getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
 490 getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
 491 \end{code}
 492
 493 \begin{code}
 494 getDefaultingTys :: NF_TcM [UniType]
 495 getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
 496
 497 setDefaultingTys :: [UniType] -> TcM a -> TcM a
 498 setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
 499   = action sw_chkr dtys subst us errs src_loc
 500 \end{code}
 501
 502 \begin{code}
 503 addSrcLocTc :: SrcLoc -> TcM a -> TcM a
 504 addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
 505   = expr sw_chkr dtys subst us errs new_locn
 506
 507 getSrcLocTc :: NF_TcM SrcLoc
 508 getSrcLocTc sw_chkr dtys subst us errs src_loc
 509   = (src_loc, subst, errs)
 510 \end{code}
 511
 512 %************************************************************************
 513 %*                                                                      *
 514 \subsection[TcM-check]{Error-detecting functions}
 515 %*                                                                      *
 516 %************************************************************************
 517
 518 The following TcM checks a Maybe type and fails with the given
 519 error message.
 520
 521 \begin{code}
 522 checkMaybeTc :: Maybe val -> Error -> TcM val
 523 checkMaybeTc (Just result) err = returnTc result
 524 checkMaybeTc Nothing       err = failTc   err
 525
 526 checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
 527 checkMaybesTc []            err = returnTc []
 528 checkMaybesTc (Nothing:xs)  err = failTc   err
 529 checkMaybesTc ((Just v):xs) err
 530   = checkMaybesTc xs err `thenTc` \ xs2 ->
 531     returnTc (v:xs2)
 532
 533 checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
 534 checkMaybeErrTc (Succeeded result) errfun = returnTc result
 535 checkMaybeErrTc (Failed err)       errfun = failTc (errfun err)
 536
 537 {- UNUSED:
 538 checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
 539
 540 checkMaybeErrsTc []                 err_fun = returnTc []
 541 checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
 542 checkMaybeErrsTc ((Succeeded v):xs) err_fun
 543   = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
 544     returnTc (v:xs2)
 545 -}
 546 \end{code}
 547
 548 %************************************************************************
 549 %*                                                                      *
 550 \subsection[TcM-Insts]{Looking up instances}
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
 556
 557 lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
 558   = case (lookupInst uniqs inst) of
 559       Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
 560
 561       Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
 562
 563 lookupNoBindInst_Tc :: Inst -> TcM [Inst]
 564
 565 lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
 566   = case (lookupNoBindInst uniqs inst) of
 567       Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
 568
 569       Just insts -> TcSucceeded insts subst errs
 570 \end{code}
 571
 572
 573
 574
 575
 576
 577
 578 %************************************************************************
 579 %*                                                                      *
 580 \subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 The "baby" Tc monad doesn't pass around the substitution.
 585 That means you can't use it to type-check bindings, but you can use
 586 if for everything else (interfaces, type decls, first pass of class and
 587 instance decls etc).
 588
 589 Less importantly, it doesn't pass around the list of default decls either.
 590
 591
 592 Type declarations
 593 ~~~~~~~~~~~~~~~~~
 594
 595 \begin{code}
 596 type Baby_TcM result
 597         =  (GlobalSwitch -> Bool)
 598         -> SplitUniqSupply
 599         -> Bag Error                    -- threaded
 600         -> SrcLoc                       -- only passed downwards
 601         -> Baby_TcResult result
 602
 603 data Baby_TcResult result
 604   = BabyTcFailed    (Bag Error)
 605
 606   | BabyTcSucceeded result (Bag Error)
 607 \end{code}
 608
 609
 610 Standard plumbing
 611 ~~~~~~~~~~~~~~~~~
 612
 613 \begin{code}
 614 thenB_Tc   :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
 615 returnB_Tc :: a -> Baby_TcM a
 616
 617 #ifdef __GLASGOW_HASKELL__
 618 {-# INLINE thenB_Tc #-}
 619 {-# INLINE returnB_Tc #-}
 620 #endif
 621
 622 thenB_Tc a b sw us errs loc
 623   = case (splitUniqSupply us) of { (s1, s2) ->
 624     case (a sw s1 errs loc) of
 625       BabyTcFailed errs2          -> BabyTcFailed errs2
 626       BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
 627     }
 628
 629 returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
 630 failB_Tc   err    sw us errs loc = BabyTcFailed (errs `snocBag` err)
 631
 632 recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
 633   = BabyTcSucceeded result errs
 634   where
 635     result = case try_this sw us emptyBag loc of
 636                 BabyTcSucceeded result errs_from_branch -> result
 637                 BabyTcFailed errs_from_branch           -> return_on_failure
 638
 639 fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
 640 fixB_Tc k sw us errs loc
 641   = result
 642   where
 643     result = k val sw us errs loc
 644     val = case result of
 645             BabyTcSucceeded val errs -> val
 646             BabyTcFailed errs        -> panic "fixB_Tc failed"
 647
 648 babyTcMtoTcM :: Baby_TcM a -> TcM a
 649 babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
 650   = case m sw_chkr us errs src_loc of
 651         BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
 652         BabyTcFailed errs2           -> TcFailed subst errs2
 653
 654 babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
 655 babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
 656   = case m sw_chkr us errs src_loc of
 657         BabyTcSucceeded result errs2 -> (result, subst, errs2)
 658         BabyTcFailed errs2           -> panic "babyTcMtoNF_TcM"
 659 \end{code}
 660
 661 \begin{code}
 662 uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
 663
 664 uniqSMtoBabyTcM u_action sw us errs loc
 665   = let
 666         u_result = u_action us
 667         -- at least one use *needs* this laziness
 668     in
 669     BabyTcSucceeded u_result errs
 670 \end{code}
 671
 672 \begin{code}
 673 thenB_Tc_ m k = m `thenB_Tc` \ _ ->
 674                 k
 675
 676 mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
 677 mapB_Tc f []     = returnB_Tc []
 678 mapB_Tc f (x:xs) = f x          `thenB_Tc` \ fx ->
 679                    mapB_Tc f xs `thenB_Tc` \ fxs ->
 680                    returnB_Tc (fx:fxs)
 681 \end{code}
 682
 683
 684 Primitives
 685 ~~~~~~~~~~
 686
 687 \begin{code}
 688 getUniqueB_Tc  :: Baby_TcM Unique
 689 getUniquesB_Tc :: Int -> Baby_TcM [Unique]
 690
 691 getUniqueB_Tc sw us errs loc
 692   = case (getSUnique us) of { unique ->
 693     BabyTcSucceeded unique errs }
 694
 695 getUniquesB_Tc n sw us errs loc
 696   = case (getSUniques n us) of { uniques ->
 697     BabyTcSucceeded uniques errs }
 698
 699 addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
 700 addSrcLocB_Tc new_locn m sw us errs loc
 701   = m sw us errs new_locn
 702
 703 getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
 704
 705 getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
 706 getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
 707 \end{code}
 708
 709
 710 Useful functions
 711 ~~~~~~~~~~~~~~~~
 712
 713 \begin{code}
 714 checkB_Tc :: Bool -> Error -> Baby_TcM ()
 715
 716 checkB_Tc True  err = failB_Tc err
 717 checkB_Tc False err = returnB_Tc ()
 718 \end{code}