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