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