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, thenLazilyNF_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`, `thenLazilyNF_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 thenLazilyNF_Tc #-}
 282 {-# INLINE returnNF_Tc #-}
 283 #endif
 284
 285 thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
 286 -- ...Lazily... is purely a performance thing (WDP 95/09)
 287 \end{code}
 288
 289 In particular, @thenNF_Tc@ has all of these types:
 290 \begin{pseudocode}
 291 thenNF_Tc :: NF_TcM a -> (a -> TcM b)    -> TcM b
 292 thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
 293 \end{pseudocode}
 294
 295 \begin{code}
 296 thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
 297   = case splitUniqSupply us         of { (s1, s2) ->
 298     case (expr sw_chkr dtys subst s1 errs src_loc) of
 299      (result, subst2, errs2)
 300        -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
 301     }
 302
 303 thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
 304   = let
 305         (s1, s2) = splitUniqSupply us
 306     in
 307     case (expr sw_chkr dtys subst s1 errs src_loc) of {
 308      (result, subst2, errs2)
 309        -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
 310     }
 311
 312 returnNF_Tc :: a -> NF_TcM a
 313 returnNF_Tc result sw_chkr dtys subst us errs src_loc
 314   = (result, subst, errs)
 315
 316 listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
 317 listNF_Tc [] = returnNF_Tc []
 318 listNF_Tc (x:xs)
 319   = x                   `thenNF_Tc` \ r ->
 320     listNF_Tc xs        `thenNF_Tc` \ rs ->
 321     returnNF_Tc (r:rs)
 322
 323 mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
 324 mapNF_Tc f [] = returnNF_Tc []
 325 mapNF_Tc f (x:xs)
 326   = f x                 `thenNF_Tc` \ r ->
 327     mapNF_Tc f xs       `thenNF_Tc` \ rs ->
 328     returnNF_Tc (r:rs)
 329
 330 fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
 331 fixNF_Tc m sw_chkr dtys subst us errs src_loc
 332   = lim
 333   where
 334     lim = m result sw_chkr dtys subst us errs src_loc
 335     (result, _, _) = lim
 336 \end{code}
 337
 338 @noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}.  You use it
 339 when you are darn sure that the TcM won't actually fail!
 340
 341 \begin{code}
 342 noFailTc :: TcM a -> NF_TcM a
 343
 344 noFailTc expr sw_chkr dtys subst us errs src_loc
 345   = case (expr sw_chkr dtys subst us errs src_loc) of
 346       TcFailed _ _ -> panic "Failure in noFailTc!"
 347       TcSucceeded result subst errs
 348         -> (result, subst, errs)
 349 \end{code}
 350
 351 %************************************************************************
 352 %*                                                                      *
 353 \subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
 354 %*                                                                      *
 355 %************************************************************************
 356
 357 These functions extract uniques from the monad. There are two unique
 358 supplies embedded in the monad.
 359 \begin{itemize}
 360 \item
 361 normal unique supply
 362 \item
 363 special unique supply for TyVars (these index the substitution)
 364 \end{itemize}
 365
 366 \begin{code}
 367 getUniquesTc :: Int -> NF_TcM [Unique]
 368 getUniquesTc n sw_chkr dtys subst us errs src_loc
 369   = case (getSUniques n us) of { uniques ->
 370     (uniques, subst, errs) }
 371
 372 -- This simpler version is often adequate:
 373
 374 getUniqueTc :: NF_TcM Unique
 375 getUniqueTc sw_chkr dtys subst us errs src_loc
 376   = case (getSUnique us) of { unique ->
 377     (unique, subst, errs) }
 378
 379 rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
 380
 381 rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
 382   = let
 383         (rn_result, rn_errs)
 384           = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
 385             -- laziness may be good for you (see below)
 386     in
 387     ((rn_result, rn_errs), subst, errs)
 388
 389 -- Special uniques for TyVars extracted from the substitution
 390
 391 getTyVarUniquesTc :: Int -> NF_TcM [Unique]
 392 getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
 393   = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
 394   where
 395     (subst2, uniques) = getSubstTyVarUniques n subst
 396
 397 getTyVarUniqueTc :: NF_TcM Unique
 398 getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
 399   = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
 400   where
 401     (subst2, unique) = getSubstTyVarUnique subst
 402 \end{code}
 403
 404 %************************************************************************
 405 %*                                                                      *
 406 \subsection[TcM-extract]{Extractings other things from the monad}
 407 %*                                                                      *
 408 %************************************************************************
 409
 410 These are functions which extract things from the monad.
 411
 412 Extending and applying the substitution.
 413
 414 ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
 415 a number of places where only the sequenced substitution is required.
 416 A lighter weight sequence substitution monad would be more appropriate
 417 with TcMonad interface functions defined here.
 418
 419 \begin{code}
 420 getTcSubst            ::              NF_TcM Subst
 421 applyTcSubstToTy      :: TauType   -> NF_TcM TauType
 422 --UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType
 423 applyTcSubstToTyVar   :: TyVar     -> NF_TcM TauType
 424 applyTcSubstToId      :: Id        -> NF_TcM Id
 425 applyTcSubstToInst    :: Inst      -> NF_TcM Inst
 426
 427 getTcSubst sw_chkr dtys subst us errs src_loc
 428   = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
 429
 430 applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
 431   = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
 432     returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
 433     }
 434
 435 {- UNUSED:
 436 applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
 437   = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
 438     returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
 439     }
 440 -}
 441
 442 applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
 443   = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
 444     returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
 445     }
 446
 447 applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
 448   = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
 449     returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
 450     }
 451
 452 applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
 453   = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
 454     returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
 455     }
 456
 457 applyTcSubstToTyVars :: [TyVar]   -> NF_TcM [UniType]
 458 applyTcSubstToTys    :: [TauType] -> NF_TcM [TauType]
 459
 460 applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
 461 applyTcSubstToTys    tys    = mapNF_Tc applyTcSubstToTy    tys
 462 applyTcSubstToInsts  insts  = mapNF_Tc applyTcSubstToInst  insts
 463 \end{code}
 464
 465 \begin{code}
 466 extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
 467
 468 extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
 469   = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
 470     case extend_result of
 471       SubstOK ->
 472         TcSucceeded () new_subst errs
 473
 474       OccursCheck tyvar ty ->
 475         TcFailed new_subst
 476                  (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
 477
 478       AlreadyBound ty1 ->
 479             -- This should only happen in the case of a call to
 480             -- extendSubstTc from the unifier!  The way things are now
 481             -- we can't check for the AlreadyBound case in other calls
 482             -- to extendSubstTc, but we're confident it never shows up.
 483             -- Ugh!
 484         unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
 485     }
 486 \end{code}
 487
 488
 489 @pruneSubstTc@ does nothing with an array substitution implementation!!!
 490 \begin{code}
 491 pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
 492              -> TcM a   -- Type-check this
 493              -> TcM a   -- Return same result but pruned subst
 494
 495 pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
 496   = m sw_chkr dtys subst uniqs errs src_loc
 497 \end{code}
 498
 499 \begin{code}
 500 getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
 501 getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
 502 \end{code}
 503
 504 \begin{code}
 505 getDefaultingTys :: NF_TcM [UniType]
 506 getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
 507
 508 setDefaultingTys :: [UniType] -> TcM a -> TcM a
 509 setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
 510   = action sw_chkr dtys subst us errs src_loc
 511 \end{code}
 512
 513 \begin{code}
 514 addSrcLocTc :: SrcLoc -> TcM a -> TcM a
 515 addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
 516   = expr sw_chkr dtys subst us errs new_locn
 517
 518 getSrcLocTc :: NF_TcM SrcLoc
 519 getSrcLocTc sw_chkr dtys subst us errs src_loc
 520   = (src_loc, subst, errs)
 521 \end{code}
 522
 523 %************************************************************************
 524 %*                                                                      *
 525 \subsection[TcM-check]{Error-detecting functions}
 526 %*                                                                      *
 527 %************************************************************************
 528
 529 The following TcM checks a Maybe type and fails with the given
 530 error message.
 531
 532 \begin{code}
 533 checkMaybeTc :: Maybe val -> Error -> TcM val
 534 checkMaybeTc (Just result) err = returnTc result
 535 checkMaybeTc Nothing       err = failTc   err
 536
 537 checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
 538 checkMaybesTc []            err = returnTc []
 539 checkMaybesTc (Nothing:xs)  err = failTc   err
 540 checkMaybesTc ((Just v):xs) err
 541   = checkMaybesTc xs err `thenTc` \ xs2 ->
 542     returnTc (v:xs2)
 543
 544 checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
 545 checkMaybeErrTc (Succeeded result) errfun = returnTc result
 546 checkMaybeErrTc (Failed err)       errfun = failTc (errfun err)
 547
 548 {- UNUSED:
 549 checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
 550
 551 checkMaybeErrsTc []                 err_fun = returnTc []
 552 checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
 553 checkMaybeErrsTc ((Succeeded v):xs) err_fun
 554   = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
 555     returnTc (v:xs2)
 556 -}
 557 \end{code}
 558
 559 %************************************************************************
 560 %*                                                                      *
 561 \subsection[TcM-Insts]{Looking up instances}
 562 %*                                                                      *
 563 %************************************************************************
 564
 565 \begin{code}
 566 lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
 567
 568 lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
 569   = case (lookupInst uniqs inst) of
 570       Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
 571
 572       Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
 573
 574 lookupNoBindInst_Tc :: Inst -> TcM [Inst]
 575
 576 lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
 577   = case (lookupNoBindInst uniqs inst) of
 578       Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
 579
 580       Just insts -> TcSucceeded insts subst errs
 581 \end{code}
 582
 583
 584
 585
 586
 587
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 The "baby" Tc monad doesn't pass around the substitution.
 596 That means you can't use it to type-check bindings, but you can use
 597 if for everything else (interfaces, type decls, first pass of class and
 598 instance decls etc).
 599
 600 Less importantly, it doesn't pass around the list of default decls either.
 601
 602
 603 Type declarations
 604 ~~~~~~~~~~~~~~~~~
 605
 606 \begin{code}
 607 type Baby_TcM result
 608         =  (GlobalSwitch -> Bool)
 609         -> SplitUniqSupply
 610         -> Bag Error                    -- threaded
 611         -> SrcLoc                       -- only passed downwards
 612         -> Baby_TcResult result
 613
 614 data Baby_TcResult result
 615   = BabyTcFailed    (Bag Error)
 616
 617   | BabyTcSucceeded result (Bag Error)
 618 \end{code}
 619
 620
 621 Standard plumbing
 622 ~~~~~~~~~~~~~~~~~
 623
 624 \begin{code}
 625 thenB_Tc   :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
 626 returnB_Tc :: a -> Baby_TcM a
 627
 628 #ifdef __GLASGOW_HASKELL__
 629 {-# INLINE thenB_Tc #-}
 630 {-# INLINE returnB_Tc #-}
 631 #endif
 632
 633 thenB_Tc a b sw us errs loc
 634   = case (splitUniqSupply us) of { (s1, s2) ->
 635     case (a sw s1 errs loc) of
 636       BabyTcFailed errs2          -> BabyTcFailed errs2
 637       BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
 638     }
 639
 640 returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
 641 failB_Tc   err    sw us errs loc = BabyTcFailed (errs `snocBag` err)
 642
 643 recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
 644   = BabyTcSucceeded result errs
 645   where
 646     result = case try_this sw us emptyBag loc of
 647                 BabyTcSucceeded result errs_from_branch -> result
 648                 BabyTcFailed errs_from_branch           -> return_on_failure
 649
 650 fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
 651 fixB_Tc k sw us errs loc
 652   = result
 653   where
 654     result = k val sw us errs loc
 655     val = case result of
 656             BabyTcSucceeded val errs -> val
 657             BabyTcFailed errs        -> panic "fixB_Tc failed"
 658
 659 babyTcMtoTcM :: Baby_TcM a -> TcM a
 660 babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
 661   = case m sw_chkr us errs src_loc of
 662         BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
 663         BabyTcFailed errs2           -> TcFailed subst errs2
 664
 665 babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
 666 babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
 667   = case m sw_chkr us errs src_loc of
 668         BabyTcSucceeded result errs2 -> (result, subst, errs2)
 669         BabyTcFailed errs2           -> panic "babyTcMtoNF_TcM"
 670 \end{code}
 671
 672 \begin{code}
 673 uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
 674
 675 uniqSMtoBabyTcM u_action sw us errs loc
 676   = let
 677         u_result = u_action us
 678         -- at least one use *needs* this laziness
 679     in
 680     BabyTcSucceeded u_result errs
 681 \end{code}
 682
 683 \begin{code}
 684 thenB_Tc_ m k = m `thenB_Tc` \ _ ->
 685                 k
 686
 687 mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
 688 mapB_Tc f []     = returnB_Tc []
 689 mapB_Tc f (x:xs) = f x          `thenB_Tc` \ fx ->
 690                    mapB_Tc f xs `thenB_Tc` \ fxs ->
 691                    returnB_Tc (fx:fxs)
 692 \end{code}
 693
 694
 695 Primitives
 696 ~~~~~~~~~~
 697
 698 \begin{code}
 699 getUniqueB_Tc  :: Baby_TcM Unique
 700 getUniquesB_Tc :: Int -> Baby_TcM [Unique]
 701
 702 getUniqueB_Tc sw us errs loc
 703   = case (getSUnique us) of { unique ->
 704     BabyTcSucceeded unique errs }
 705
 706 getUniquesB_Tc n sw us errs loc
 707   = case (getSUniques n us) of { uniques ->
 708     BabyTcSucceeded uniques errs }
 709
 710 addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
 711 addSrcLocB_Tc new_locn m sw us errs loc
 712   = m sw us errs new_locn
 713
 714 getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
 715
 716 getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
 717 getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
 718 \end{code}
 719
 720
 721 Useful functions
 722 ~~~~~~~~~~~~~~~~
 723
 724 \begin{code}
 725 checkB_Tc :: Bool -> Error -> Baby_TcM ()
 726
 727 checkB_Tc True  err = failB_Tc err
 728 checkB_Tc False err = returnB_Tc ()
 729 \end{code}