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