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