ghc/compiler/typecheck/TcMonad.lhs

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