ghc/compiler/typecheck/TcMonad.lhs

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