ghc/compiler/typecheck/TcMonad.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module TcMonad(
   5         SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
   6         SST_R, FSST_R,
   7
   8         initTc,
   9         returnTc, thenTc, thenTc_, mapTc, listTc,
  10         foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
  11         mapBagTc, fixTc, tryTc, getErrsTc,
  12
  13         returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
  14
  15         listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
  16
  17         checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
  18         failTc, warnTc, recoverTc, recoverNF_Tc,
  19
  20         tcGetEnv, tcSetEnv,
  21         tcGetDefaultTys, tcSetDefaultTys,
  22         tcGetUnique, tcGetUniques,
  23
  24         tcAddSrcLoc, tcGetSrcLoc,
  25         tcAddErrCtxtM, tcSetErrCtxtM,
  26         tcAddErrCtxt, tcSetErrCtxt,
  27
  28         tcNewMutVar, tcReadMutVar, tcWriteMutVar,
  29
  30         SYN_IE(TcError), SYN_IE(TcWarning),
  31         mkTcErr, arityErr,
  32
  33         -- For closure
  34         SYN_IE(MutableVar),
  35 #if __GLASGOW_HASKELL__ >= 200
  36         GHCbase.MutableArray
  37 #else
  38         _MutableArray
  39 #endif
  40   ) where
  41
  42 IMP_Ubiq(){-uitous-}
  43
  44 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe )  -- We need the type TcEnv and an initial Env
  45
  46 import Type             ( SYN_IE(Type), GenType )
  47 import TyVar            ( SYN_IE(TyVar), GenTyVar )
  48 import Usage            ( SYN_IE(Usage), GenUsage )
  49 import ErrUtils         ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
  50
  51 import SST
  52 import Bag              ( Bag, emptyBag, isEmptyBag,
  53                           foldBag, unitBag, unionBags, snocBag )
  54 import FiniteMap        ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
  55 import Maybes           ( MaybeErr(..) )
  56 import SrcLoc           ( SrcLoc, noSrcLoc )
  57 import UniqFM           ( UniqFM, emptyUFM )
  58 import UniqSupply       ( UniqSupply, getUnique, getUniques, splitUniqSupply )
  59 import Unique           ( Unique )
  60 import Util
  61 import Pretty
  62 import PprStyle         ( PprStyle(..) )
  63
  64 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
  65 \end{code}
  66
  67
  68 \section{TcM, NF_TcM: the type checker monads}
  69 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  70
  71 \begin{code}
  72 type NF_TcM s r =  TcDown s -> TcEnv s -> SST s r
  73 type TcM    s r =  TcDown s -> TcEnv s -> FSST s r ()
  74 \end{code}
  75
  76 \begin{code}
  77 #if __GLASGOW_HASKELL__ >= 200
  78 # define REAL_WORLD RealWorld
  79 #else
  80 # define REAL_WORLD _RealWorld
  81 #endif
  82
  83 -- With a builtin polymorphic type for runSST the type for
  84 -- initTc should use  TcM s r  instead of  TcM RealWorld r
  85
  86 initTc :: UniqSupply
  87        -> TcM REAL_WORLD r
  88        -> MaybeErr (r, Bag Warning)
  89                    (Bag Error, Bag  Warning)
  90
  91 initTc us do_this
  92   = runSST (
  93       newMutVarSST us                   `thenSST` \ us_var ->
  94       newMutVarSST (emptyBag,emptyBag)  `thenSST` \ errs_var ->
  95       newMutVarSST emptyUFM             `thenSST` \ tvs_var ->
  96       let
  97           init_down = TcDown [] us_var
  98                              noSrcLoc
  99                              [] errs_var
 100           init_env  = initEnv tvs_var
 101       in
 102       recoverSST
 103         (\_ -> returnSST Nothing)
 104         (do_this init_down init_env `thenFSST` \ res ->
 105          returnFSST (Just res))
 106                                         `thenSST` \ maybe_res ->
 107       readMutVarSST errs_var            `thenSST` \ (warns,errs) ->
 108       case (maybe_res, isEmptyBag errs) of
 109         (Just res, True) -> returnSST (Succeeded (res, warns))
 110         _                -> returnSST (Failed (errs, warns))
 111     )
 112
 113 thenNF_Tc :: NF_TcM s a
 114           -> (a -> TcDown s -> TcEnv s -> State# s -> b)
 115           -> TcDown s -> TcEnv s -> State# s -> b
 116 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
 117 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b)    -> TcM s b
 118
 119 thenNF_Tc m k down env
 120   = m down env  `thenSST` \ r ->
 121     k r down env
 122
 123 thenNF_Tc_ :: NF_TcM s a
 124            -> (TcDown s -> TcEnv s -> State# s -> b)
 125            -> TcDown s -> TcEnv s -> State# s -> b
 126 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
 127 -- thenNF_Tc :: NF_TcM s a -> TcM s b    -> TcM s b
 128
 129 thenNF_Tc_ m k down env
 130   = m down env  `thenSST_` k down env
 131
 132 returnNF_Tc :: a -> NF_TcM s a
 133 returnNF_Tc v down env = returnSST v
 134
 135 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
 136 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
 137
 138 mapNF_Tc    :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
 139 mapNF_Tc f []     = returnNF_Tc []
 140 mapNF_Tc f (x:xs) = f x                 `thenNF_Tc` \ r ->
 141                     mapNF_Tc f xs       `thenNF_Tc` \ rs ->
 142                     returnNF_Tc (r:rs)
 143
 144 listNF_Tc    :: [NF_TcM s a] -> NF_TcM s [a]
 145 listNF_Tc []     = returnNF_Tc []
 146 listNF_Tc (x:xs) = x                    `thenNF_Tc` \ r ->
 147                    listNF_Tc xs         `thenNF_Tc` \ rs ->
 148                    returnNF_Tc (r:rs)
 149
 150 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
 151 mapBagNF_Tc f bag
 152   = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
 153                         b2 `thenNF_Tc` \ r2 ->
 154                         returnNF_Tc (unionBags r1 r2))
 155             (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
 156             (returnNF_Tc emptyBag)
 157             bag
 158
 159 mapAndUnzipNF_Tc    :: (a -> NF_TcM s (b,c)) -> [a]   -> NF_TcM s ([b],[c])
 160 mapAndUnzipNF_Tc f []     = returnNF_Tc ([],[])
 161 mapAndUnzipNF_Tc f (x:xs) = f x                         `thenNF_Tc` \ (r1,r2) ->
 162                             mapAndUnzipNF_Tc f xs       `thenNF_Tc` \ (rs1,rs2) ->
 163                             returnNF_Tc (r1:rs1, r2:rs2)
 164
 165 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
 166 thenTc m k down env
 167   = m down env  `thenFSST` \ r ->
 168     k r down env
 169
 170 thenTc_ :: TcM s a -> TcM s b -> TcM s b
 171 thenTc_ m k down env
 172   = m down env  `thenFSST_`  k down env
 173
 174 returnTc :: a -> TcM s a
 175 returnTc val down env = returnFSST val
 176
 177 mapTc    :: (a -> TcM s b) -> [a]   -> TcM s [b]
 178 mapTc f []     = returnTc []
 179 mapTc f (x:xs) = f x            `thenTc` \ r ->
 180                  mapTc f xs     `thenTc` \ rs ->
 181                  returnTc (r:rs)
 182
 183 listTc    :: [TcM s a] -> TcM s [a]
 184 listTc []     = returnTc []
 185 listTc (x:xs) = x                       `thenTc` \ r ->
 186                 listTc xs               `thenTc` \ rs ->
 187                 returnTc (r:rs)
 188
 189 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
 190 foldrTc k z []     = returnTc z
 191 foldrTc k z (x:xs) = foldrTc k z xs     `thenTc` \r ->
 192                      k x r
 193
 194 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
 195 foldlTc k z []     = returnTc z
 196 foldlTc k z (x:xs) = k z x              `thenTc` \r ->
 197                      foldlTc k r xs
 198
 199 mapAndUnzipTc    :: (a -> TcM s (b,c)) -> [a]   -> TcM s ([b],[c])
 200 mapAndUnzipTc f []     = returnTc ([],[])
 201 mapAndUnzipTc f (x:xs) = f x                    `thenTc` \ (r1,r2) ->
 202                          mapAndUnzipTc f xs     `thenTc` \ (rs1,rs2) ->
 203                          returnTc (r1:rs1, r2:rs2)
 204
 205 mapAndUnzip3Tc    :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
 206 mapAndUnzip3Tc f []     = returnTc ([],[],[])
 207 mapAndUnzip3Tc f (x:xs) = f x                   `thenTc` \ (r1,r2,r3) ->
 208                           mapAndUnzip3Tc f xs   `thenTc` \ (rs1,rs2,rs3) ->
 209                           returnTc (r1:rs1, r2:rs2, r3:rs3)
 210
 211 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
 212 mapBagTc f bag
 213   = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
 214                         b2 `thenTc` \ r2 ->
 215                         returnTc (unionBags r1 r2))
 216             (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
 217             (returnTc emptyBag)
 218             bag
 219
 220 fixTc :: (a -> TcM s a) -> TcM s a
 221 fixTc m env down = fixFSST (\ loop -> m loop env down)
 222 \end{code}
 223
 224 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
 225 thread.  Ideally, this elegantly ensures that it can't zap any type
 226 variables that belong to the main thread.  But alas, the environment
 227 contains TyCon and Class environments that include (TcKind s) stuff,
 228 which is a Royal Pain.  By the time this fork stuff is used they'll
 229 have been unified down so there won't be any kind variables, but we
 230 can't express that in the current typechecker framework.
 231
 232 So we compromise and use unsafeInterleaveSST.
 233
 234 We throw away any error messages!
 235
 236 \begin{code}
 237 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
 238 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
 239   =     -- Get a fresh unique supply
 240     readMutVarSST u_var         `thenSST` \ us ->
 241     let
 242         (us1, us2) = splitUniqSupply us
 243     in
 244     writeMutVarSST u_var us1    `thenSST_`
 245
 246     unsafeInterleaveSST (
 247         newMutVarSST us2                        `thenSST` \ us_var'   ->
 248         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ err_var' ->
 249         newMutVarSST emptyUFM                   `thenSST` \ tv_var'  ->
 250         let
 251             down' = TcDown deflts us_var' src_loc err_cxt err_var'
 252         in
 253         m down' env
 254         -- ToDo: optionally dump any error messages
 255     )
 256 \end{code}
 257
 258
 259 Error handling
 260 ~~~~~~~~~~~~~~
 261 \begin{code}
 262 getErrsTc :: NF_TcM s (Bag Error, Bag  Warning)
 263 getErrsTc down env
 264   = readMutVarSST errs_var
 265   where
 266     errs_var = getTcErrs down
 267
 268 failTc :: Message -> TcM s a
 269 failTc err_msg down env
 270   = readMutVarSST errs_var      `thenSST` \ (warns,errs) ->
 271     listNF_Tc ctxt down env     `thenSST` \ ctxt_msgs ->
 272     let
 273         err = mkTcErr loc ctxt_msgs err_msg
 274     in
 275     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 276     failFSST ()
 277   where
 278     errs_var = getTcErrs down
 279     ctxt     = getErrCtxt down
 280     loc      = getLoc down
 281
 282 warnTc :: Bool -> Message -> NF_TcM s ()
 283 warnTc warn_if_true warn down env
 284   = if warn_if_true then
 285         readMutVarSST errs_var                                  `thenSST` \ (warns,errs) ->
 286         writeMutVarSST errs_var (warns `snocBag` warn, errs)    `thenSST_`
 287         returnSST ()
 288     else
 289         returnSST ()
 290   where
 291     errs_var = getTcErrs down
 292
 293 recoverTc :: TcM s r -> TcM s r -> TcM s r
 294 recoverTc recover m down env
 295   = recoverFSST (\ _ -> recover down env) (m down env)
 296
 297 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
 298 recoverNF_Tc recover m down env
 299   = recoverSST (\ _ -> recover down env) (m down env)
 300
 301 -- (tryTc r m) tries m; if it succeeds it returns it,
 302 -- otherwise it returns r.  Any error messages added by m are discarded,
 303 -- whether or not m succeeds.
 304 tryTc :: TcM s r -> TcM s r -> TcM s r
 305 tryTc recover m down env
 306   = recoverFSST (\ _ -> recover down env) $
 307
 308     newMutVarSST (emptyBag,emptyBag)    `thenSST` \ new_errs_var ->
 309
 310     m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
 311
 312         -- Check that m has no errors; if it has internal recovery
 313         -- mechanisms it might "succeed" but having found a bunch of
 314         -- errors along the way. If so we want tryTc to use
 315         -- "recover" instead
 316     readMutVarSST new_errs_var          `thenSST` \ (_,errs) ->
 317     if isEmptyBag errs then
 318         returnFSST result
 319     else
 320         recover down env
 321
 322 checkTc :: Bool -> Message -> TcM s ()          -- Check that the boolean is true
 323 checkTc True  err = returnTc ()
 324 checkTc False err = failTc err
 325
 326 checkTcM :: Bool -> TcM s () -> TcM s ()        -- Check that the boolean is true
 327 checkTcM True  err = returnTc ()
 328 checkTcM False err = err
 329
 330 checkMaybeTc :: Maybe val -> Message -> TcM s val
 331 checkMaybeTc (Just val) err = returnTc val
 332 checkMaybeTc Nothing    err = failTc err
 333
 334 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
 335 checkMaybeTcM (Just val) err = returnTc val
 336 checkMaybeTcM Nothing    err = err
 337 \end{code}
 338
 339 Mutable variables
 340 ~~~~~~~~~~~~~~~~~
 341 \begin{code}
 342 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
 343 tcNewMutVar val down env = newMutVarSST val
 344
 345 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
 346 tcWriteMutVar var val down env = writeMutVarSST var val
 347
 348 tcReadMutVar :: MutableVar s a -> NF_TcM s a
 349 tcReadMutVar var down env = readMutVarSST var
 350 \end{code}
 351
 352
 353 Environment
 354 ~~~~~~~~~~~
 355 \begin{code}
 356 tcGetEnv :: NF_TcM s (TcEnv s)
 357 tcGetEnv down env = returnSST env
 358
 359 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
 360 tcSetEnv new_env m down old_env = m down new_env
 361 \end{code}
 362
 363
 364 Source location
 365 ~~~~~~~~~~~~~~~
 366 \begin{code}
 367 tcGetDefaultTys :: NF_TcM s [Type]
 368 tcGetDefaultTys down env = returnSST (getDefaultTys down)
 369
 370 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
 371 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
 372
 373 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
 374 tcAddSrcLoc loc m down env = m (setLoc down loc) env
 375
 376 tcGetSrcLoc :: NF_TcM s SrcLoc
 377 tcGetSrcLoc down env = returnSST (getLoc down)
 378
 379 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
 380 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
 381 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
 382
 383 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
 384 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
 385 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
 386 \end{code}
 387
 388
 389 Unique supply
 390 ~~~~~~~~~~~~~
 391 \begin{code}
 392 tcGetUnique :: NF_TcM s Unique
 393 tcGetUnique down env
 394   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 395     let
 396       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 397       uniq                      = getUnique uniq_s
 398     in
 399     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 400     returnSST uniq
 401   where
 402     u_var = getUniqSupplyVar down
 403
 404 tcGetUniques :: Int -> NF_TcM s [Unique]
 405 tcGetUniques n down env
 406   = readMutVarSST u_var                         `thenSST` \ uniq_supply ->
 407     let
 408       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 409       uniqs                     = getUniques n uniq_s
 410     in
 411     writeMutVarSST u_var new_uniq_supply                `thenSST_`
 412     returnSST uniqs
 413   where
 414     u_var = getUniqSupplyVar down
 415 \end{code}
 416
 417
 418 \section{TcDown}
 419 %~~~~~~~~~~~~~~~
 420
 421 \begin{code}
 422 data TcDown s
 423   = TcDown
 424         [Type]                          -- Types used for defaulting
 425
 426         (MutableVar s UniqSupply)       -- Unique supply
 427
 428         SrcLoc                          -- Source location
 429         (ErrCtxt s)                     -- Error context
 430         (MutableVar s (Bag Warning,
 431                        Bag Error))
 432
 433 type ErrCtxt s = [NF_TcM s Message]     -- Innermost first.  Monadic so that we have a chance
 434                                         -- to deal with bound type variables just before error
 435                                         -- message construction
 436 \end{code}
 437
 438 -- These selectors are *local* to TcMonad.lhs
 439
 440 \begin{code}
 441 getTcErrs (TcDown def us loc ctxt errs)      = errs
 442 setTcErrs (TcDown def us loc ctxt _   ) errs = TcDown def us loc ctxt errs
 443
 444 getDefaultTys (TcDown def us loc ctxt errs)     = def
 445 setDefaultTys (TcDown _   us loc ctxt errs) def = TcDown def us loc ctxt errs
 446
 447 getLoc (TcDown def us loc ctxt errs)     = loc
 448 setLoc (TcDown def us _   ctxt errs) loc = TcDown def us loc ctxt errs
 449
 450 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
 451
 452 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg]      errs
 453 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
 454 getErrCtxt (TcDown def us loc ctxt errs)     = ctxt
 455 \end{code}
 456
 457
 458
 459
 460 TypeChecking Errors
 461 ~~~~~~~~~~~~~~~~~~~
 462
 463 \begin{code}
 464 type TcError   = Message
 465 type TcWarning = Message
 466
 467 mkTcErr :: SrcLoc               -- Where
 468         -> [Message]            -- Context
 469         -> Message              -- What went wrong
 470         -> TcError              -- The complete error report
 471
 472 mkTcErr locn ctxt msg sty
 473   = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
 474          4 (ppAboves [msg sty | msg <- ctxt])
 475
 476
 477 arityErr kind name n m sty
 478   = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
 479                 n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
 480     where
 481         errmsg = kind ++ " has too " ++ quantity ++ " arguments"
 482         quantity | m < n     = "few"
 483                  | otherwise = "many"
 484         n_arguments | n == 0 = ppStr "no arguments"
 485                     | n == 1 = ppStr "1 argument"
 486                     | True   = ppCat [ppInt n, ppStr "arguments"]
 487 \end{code}
 488
 489