ghc/compiler/typecheck/TcMonad.lhs

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