ghc/compiler/typecheck/TcMonad.lhs

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