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