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