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