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