ghc/compiler/typecheck/TcBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcBinds]{TcBinds}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcBinds ( tcBindsAndThen, tcPragmaSigs, checkSigTyVars, tcBindWithSigs, TcSigInfo(..) ) where
  10
  11 IMP_Ubiq()
  12 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  13 IMPORT_DELOOPER(TcLoop)         ( tcGRHSsAndBinds )
  14 #else
  15 import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
  16 #endif
  17
  18 import HsSyn            ( HsBinds(..), Sig(..), MonoBinds(..),
  19                           Match, HsType, InPat(..), OutPat(..), HsExpr(..),
  20                           SYN_IE(RecFlag), nonRecursive,
  21                           GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, Stmt, DoOrListComp, Fixity,
  22                           collectMonoBinders )
  23 import RnHsSyn          ( SYN_IE(RenamedHsBinds), RenamedSig(..),
  24                           SYN_IE(RenamedMonoBinds)
  25                         )
  26 import TcHsSyn          ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds),
  27                           SYN_IE(TcExpr),
  28                           tcIdType
  29                         )
  30
  31 import TcMonad
  32 import Inst             ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..),
  33                           newDicts, tyVarsOfInst, instToId
  34                         )
  35 import TcEnv            ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds,
  36                           tcGetGlobalTyVars, tcExtendGlobalTyVars
  37                         )
  38 import SpecEnv          ( SpecEnv )
  39 import TcMatches        ( tcMatchesFun )
  40 import TcSimplify       ( tcSimplify, tcSimplifyAndCheck )
  41 import TcMonoType       ( tcHsType )
  42 import TcPat            ( tcPat )
  43 import TcSimplify       ( bindInstsOfLocalFuns )
  44 import TcType           ( TcIdOcc(..), SYN_IE(TcIdBndr),
  45                           SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType),
  46                           SYN_IE(TcTyVarSet), SYN_IE(TcTyVar),
  47                           newTyVarTy, zonkTcType, zonkSigTyVar,
  48                           newTcTyVar, tcInstSigType, newTyVarTys
  49                         )
  50 import Unify            ( unifyTauTy, unifyTauTyLists )
  51
  52 import Kind             ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
  53 import Id               ( GenId, idType, mkUserLocal, mkUserId )
  54 import IdInfo           ( noIdInfo )
  55 import Maybes           ( maybeToBool, assocMaybe, catMaybes )
  56 import Name             ( getOccName, getSrcLoc, Name )
  57 import PragmaInfo       ( PragmaInfo(..) )
  58 import Pretty
  59 import Type             ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta,
  60                           mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
  61                           splitRhoTy, mkForAllTy, splitForAllTy )
  62 import TyVar            ( GenTyVar, SYN_IE(TyVar), tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
  63                           elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
  64 import Bag              ( bagToList, foldrBag, isEmptyBag )
  65 import Util             ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc,
  66                           assertPanic, panic, pprTrace )
  67 import PprType          ( GenClass, GenType, GenTyVar )
  68 import Unique           ( Unique )
  69 import SrcLoc           ( SrcLoc )
  70
  71 import Outputable       --( interppSP, interpp'SP )
  72
  73
  74 \end{code}
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{Type-checking bindings}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 @tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
  84 it needs to know something about the {\em usage} of the things bound,
  85 so that it can create specialisations of them.  So @tcBindsAndThen@
  86 takes a function which, given an extended environment, E, typechecks
  87 the scope of the bindings returning a typechecked thing and (most
  88 important) an LIE.  It is this LIE which is then used as the basis for
  89 specialising the things bound.
  90
  91 @tcBindsAndThen@ also takes a "combiner" which glues together the
  92 bindings and the "thing" to make a new "thing".
  93
  94 The real work is done by @tcBindWithSigsAndThen@.
  95
  96 Recursive and non-recursive binds are handled in essentially the same
  97 way: because of uniques there are no scoping issues left.  The only
  98 difference is that non-recursive bindings can bind primitive values.
  99
 100 Even for non-recursive binding groups we add typings for each binder
 101 to the LVE for the following reason.  When each individual binding is
 102 checked the type of its LHS is unified with that of its RHS; and
 103 type-checking the LHS of course requires that the binder is in scope.
 104
 105 At the top-level the LIE is sure to contain nothing but constant
 106 dictionaries, which we resolve at the module level.
 107
 108 \begin{code}
 109 tcBindsAndThen
 110         :: (RecFlag -> TcMonoBinds s -> thing -> thing)         -- Combinator
 111         -> RenamedHsBinds
 112         -> TcM s (thing, LIE s)
 113         -> TcM s (thing, LIE s)
 114
 115 tcBindsAndThen combiner EmptyBinds do_next
 116   = do_next     `thenTc` \ (thing, lie) ->
 117     returnTc (combiner nonRecursive EmptyMonoBinds thing, lie)
 118
 119 tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
 120   = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
 121
 122 tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next
 123   = fixTc (\ ~(prag_info_fn, _) ->
 124         -- This is the usual prag_info fix; the PragmaInfo field of an Id
 125         -- is not inspected till ages later in the compiler, so there
 126         -- should be no black-hole problems here.
 127
 128         -- TYPECHECK THE SIGNATURES
 129     mapTc (tcTySig prag_info_fn) ty_sigs                `thenTc` \ tc_ty_sigs ->
 130
 131     tcBindWithSigs binder_names bind
 132                    tc_ty_sigs is_rec prag_info_fn       `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
 133
 134         -- Extend the environment to bind the new polymorphic Ids
 135     tcExtendLocalValEnv binder_names poly_ids $
 136
 137         -- Build bindings and IdInfos corresponding to user pragmas
 138     tcPragmaSigs sigs                   `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
 139
 140         -- Now do whatever happens next, in the augmented envt
 141     do_next                             `thenTc` \ (thing, thing_lie) ->
 142
 143         -- Create specialisations of functions bound here
 144     bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
 145                           poly_ids      `thenTc` \ (lie2, inst_mbinds) ->
 146
 147         -- All done
 148     let
 149         final_lie   = lie2 `plusLIE` poly_lie
 150         final_thing = combiner is_rec poly_binds $
 151                       combiner nonRecursive inst_mbinds $
 152                       combiner nonRecursive prag_binds
 153                       thing
 154     in
 155     returnTc (prag_info_fn, (final_thing, final_lie))
 156     )                                   `thenTc` \ (_, result) ->
 157     returnTc result
 158   where
 159     binder_names = map fst (bagToList (collectMonoBinders bind))
 160     ty_sigs      = [sig  | sig@(Sig name _ _) <- sigs]
 161 \end{code}
 162
 163 An aside.  The original version of @tcBindsAndThen@ which lacks a
 164 combiner function, appears below.  Though it is perfectly well
 165 behaved, it cannot be typed by Haskell, because the recursive call is
 166 at a different type to the definition itself.  There aren't too many
 167 examples of this, which is why I thought it worth preserving! [SLPJ]
 168
 169 \begin{pseudocode}
 170 tcBindsAndThen
 171         :: RenamedHsBinds
 172         -> TcM s (thing, LIE s, thing_ty))
 173         -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
 174
 175 tcBindsAndThen EmptyBinds do_next
 176   = do_next             `thenTc` \ (thing, lie, thing_ty) ->
 177     returnTc ((EmptyBinds, thing), lie, thing_ty)
 178
 179 tcBindsAndThen (ThenBinds binds1 binds2) do_next
 180   = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
 181         `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
 182
 183     returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
 184
 185 tcBindsAndThen (MonoBind bind sigs is_rec) do_next
 186   = tcBindAndThen bind sigs do_next
 187 \end{pseudocode}
 188
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection{tcBindWithSigs}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 @tcBindWithSigs@ deals with a single binding group.  It does generalisation,
 197 so all the clever stuff is in here.
 198
 199 * binder_names and mbind must define the same set of Names
 200
 201 * The Names in tc_ty_sigs must be a subset of binder_names
 202
 203 * The Ids in tc_ty_sigs don't necessarily have to have the same name
 204   as the Name in the tc_ty_sig
 205
 206 \begin{code}
 207 tcBindWithSigs
 208         :: [Name]
 209         -> RenamedMonoBinds
 210         -> [TcSigInfo s]
 211         -> RecFlag
 212         -> (Name -> PragmaInfo)
 213         -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
 214
 215 tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn
 216   = recoverTc (
 217         -- If typechecking the binds fails, then return with each
 218         -- signature-less binder given type (forall a.a), to minimise subsequent
 219         -- error messages
 220         newTcTyVar mkBoxedTypeKind              `thenNF_Tc` \ alpha_tv ->
 221         let
 222           forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
 223           poly_ids   = map mk_dummy binder_names
 224           mk_dummy name = case maybeSig tc_ty_sigs name of
 225                             Just (TySigInfo _ poly_id _ _ _ _) -> poly_id       -- Signature
 226                             Nothing -> mkUserId name forall_a_a NoPragmaInfo    -- No signature
 227         in
 228         returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
 229     ) $
 230
 231         -- Create a new identifier for each binder, with each being given
 232         -- a fresh unique, and a type-variable type.
 233     tcGetUniques no_of_binders                  `thenNF_Tc` \ uniqs ->
 234     mapNF_Tc mk_mono_id_ty binder_names         `thenNF_Tc` \ mono_id_tys ->
 235     let
 236         mono_ids           = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys
 237         mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
 238     in
 239
 240         -- TYPECHECK THE BINDINGS
 241     tcMonoBinds mbind binder_names mono_ids tc_ty_sigs  `thenTc` \ (mbind', lie) ->
 242
 243         -- CHECK THAT THE SIGNATURES MATCH
 244         -- (must do this before getTyVarsToGen)
 245     checkSigMatch tc_ty_sigs                            `thenTc` \ sig_theta ->
 246
 247         -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
 248         -- The tyvars_not_to_gen are free in the environment, and hence
 249         -- candidates for generalisation, but sometimes the monomorphism
 250         -- restriction means we can't generalise them nevertheless
 251     getTyVarsToGen is_unrestricted mono_id_tys lie      `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
 252
 253         -- DEAL WITH TYPE VARIABLE KINDS
 254     mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen)        `thenTc` \ real_tyvars_to_gen_list ->
 255     let
 256         real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
 257                 -- It's important that the final list (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
 258                 -- zonked, *including boxity*, because they'll be included in the forall types of
 259                 -- the polymorphic Ids, and instances of these Ids will be generated from them.
 260                 --
 261                 -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
 262                 -- real_tyvars_to_gen
 263                 --
 264                 -- **** This step can do unification => keep other zonking after this ****
 265     in
 266
 267         -- SIMPLIFY THE LIE
 268     tcExtendGlobalTyVars tyvars_not_to_gen (
 269         if null tc_ty_sigs then
 270                 -- No signatures, so just simplify the lie
 271             tcSimplify real_tyvars_to_gen lie           `thenTc` \ (lie_free, dict_binds, lie_bound) ->
 272             returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
 273
 274         else
 275             zonk_theta sig_theta                        `thenNF_Tc` \ sig_theta' ->
 276             newDicts SignatureOrigin sig_theta'         `thenNF_Tc` \ (dicts_sig, dict_ids) ->
 277                 -- It's important that sig_theta is zonked, because
 278                 -- dict_id is later used to form the type of the polymorphic thing,
 279                 -- and forall-types must be zonked so far as their bound variables
 280                 -- are concerned
 281
 282                 -- Check that the needed dicts can be expressed in
 283                 -- terms of the signature ones
 284             tcAddErrCtxt (sigsCtxt tysig_names) $
 285             tcSimplifyAndCheck real_tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) ->
 286             returnTc (lie_free, dict_binds, dict_ids)
 287
 288     )                                           `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
 289
 290     ASSERT( not (any (isUnboxedTypeKind . tyVarKind) real_tyvars_to_gen_list) )
 291                 -- The instCantBeGeneralised stuff in tcSimplify should have
 292                 -- already raised an error if we're trying to generalise an unboxed tyvar
 293                 -- (NB: unboxed tyvars are always introduced along with a class constraint)
 294                 -- and it's better done there because we have more precise origin information.
 295                 -- That's why we just use an ASSERT here.
 296
 297          -- BUILD THE POLYMORPHIC RESULT IDs
 298     mapNF_Tc zonkTcType mono_id_tys                     `thenNF_Tc` \ zonked_mono_id_types ->
 299     let
 300         exports  = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types
 301         dict_tys = map tcIdType dicts_bound
 302
 303         mk_export binder_name mono_id zonked_mono_id_ty
 304           | maybeToBool maybe_sig = (sig_tyvars,              TcId sig_poly_id, TcId mono_id)
 305           | otherwise             = (real_tyvars_to_gen_list, TcId poly_id,     TcId mono_id)
 306           where
 307             maybe_sig = maybeSig tc_ty_sigs binder_name
 308             Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
 309             poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
 310             poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
 311                                 -- It's important to build a fully-zonked poly_ty, because
 312                                 -- we'll slurp out its free type variables when extending the
 313                                 -- local environment (tcExtendLocalValEnv); if it's not zonked
 314                                 -- it appears to have free tyvars that aren't actually free at all.
 315     in
 316
 317          -- BUILD RESULTS
 318     returnTc (
 319          AbsBinds real_tyvars_to_gen_list
 320                   dicts_bound
 321                   exports
 322                   (dict_binds `AndMonoBinds` mbind'),
 323          lie_free,
 324          [poly_id | (_, TcId poly_id, _) <- exports]
 325     )
 326   where
 327     no_of_binders = length binder_names
 328
 329     mk_mono_id_ty binder_name = case maybeSig tc_ty_sigs binder_name of
 330                                   Just (TySigInfo name _ _ _ tau_ty _) -> returnNF_Tc tau_ty -- There's a signature
 331                                   otherwise                            -> newTyVarTy kind    -- No signature
 332
 333     tysig_names     = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
 334     is_unrestricted = isUnRestrictedGroup tysig_names mbind
 335
 336     kind | is_rec    = mkBoxedTypeKind  -- Recursive, so no unboxed types
 337          | otherwise = mkTypeKind               -- Non-recursive, so we permit unboxed types
 338
 339 zonk_theta theta = mapNF_Tc zonk theta
 340         where
 341           zonk (c,t) = zonkTcType t     `thenNF_Tc` \ t' ->
 342                        returnNF_Tc (c,t')
 343 \end{code}
 344
 345 @getImplicitStuffToGen@ decides what type variables generalise over.
 346
 347 For a "restricted group" -- see the monomorphism restriction
 348 for a definition -- we bind no dictionaries, and
 349 remove from tyvars_to_gen any constrained type variables
 350
 351 *Don't* simplify dicts at this point, because we aren't going
 352 to generalise over these dicts.  By the time we do simplify them
 353 we may well know more.  For example (this actually came up)
 354         f :: Array Int Int
 355         f x = array ... xs where xs = [1,2,3,4,5]
 356 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
 357 stuff.  If we simplify only at the f-binding (not the xs-binding)
 358 we'll know that the literals are all Ints, and we can just produce
 359 Int literals!
 360
 361 Find all the type variables involved in overloading, the
 362 "constrained_tyvars".  These are the ones we *aren't* going to
 363 generalise.  We must be careful about doing this:
 364
 365  (a) If we fail to generalise a tyvar which is not actually
 366         constrained, then it will never, ever get bound, and lands
 367         up printed out in interface files!  Notorious example:
 368                 instance Eq a => Eq (Foo a b) where ..
 369         Here, b is not constrained, even though it looks as if it is.
 370         Another, more common, example is when there's a Method inst in
 371         the LIE, whose type might very well involve non-overloaded
 372         type variables.
 373
 374  (b) On the other hand, we mustn't generalise tyvars which are constrained,
 375         because we are going to pass on out the unmodified LIE, with those
 376         tyvars in it.  They won't be in scope if we've generalised them.
 377
 378 So we are careful, and do a complete simplification just to find the
 379 constrained tyvars. We don't use any of the results, except to
 380 find which tyvars are constrained.
 381
 382 \begin{code}
 383 getTyVarsToGen is_unrestricted mono_id_tys lie
 384   = tcGetGlobalTyVars                           `thenNF_Tc` \ free_tyvars ->
 385     mapNF_Tc zonkTcType mono_id_tys             `thenNF_Tc` \ zonked_mono_id_tys ->
 386     let
 387         tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusTyVarSet` free_tyvars
 388     in
 389     if is_unrestricted
 390     then
 391         returnTc (emptyTyVarSet, tyvars_to_gen)
 392     else
 393         tcSimplify tyvars_to_gen lie        `thenTc` \ (_, _, constrained_dicts) ->
 394         let
 395           -- ASSERT: dicts_sig is already zonked!
 396             constrained_tyvars    = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts
 397             reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
 398         in
 399         returnTc (constrained_tyvars, reduced_tyvars_to_gen)
 400 \end{code}
 401
 402
 403 \begin{code}
 404 isUnRestrictedGroup :: [Name]           -- Signatures given for these
 405                     -> RenamedMonoBinds
 406                     -> Bool
 407
 408 is_elem v vs = isIn "isUnResMono" v vs
 409
 410 isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
 411 isUnRestrictedGroup sigs (PatMonoBind other      _ _)   = False
 412 isUnRestrictedGroup sigs (VarMonoBind v _)              = v `is_elem` sigs
 413 isUnRestrictedGroup sigs (FunMonoBind _ _ _ _)          = True
 414 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2)         = isUnRestrictedGroup sigs mb1 &&
 415                                                           isUnRestrictedGroup sigs mb2
 416 isUnRestrictedGroup sigs EmptyMonoBinds                 = True
 417 \end{code}
 418
 419 @defaultUncommittedTyVar@ checks for generalisation over unboxed
 420 types, and defaults any TypeKind TyVars to BoxedTypeKind.
 421
 422 \begin{code}
 423 defaultUncommittedTyVar tyvar
 424   | isTypeKind (tyVarKind tyvar)
 425   = newTcTyVar mkBoxedTypeKind                                  `thenNF_Tc` \ boxed_tyvar ->
 426     unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar)        `thenTc_`
 427     returnTc boxed_tyvar
 428
 429   | otherwise
 430   = returnTc tyvar
 431 \end{code}
 432
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection{tcMonoBind}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 @tcMonoBinds@ deals with a single @MonoBind@.
 441 The signatures have been dealt with already.
 442
 443 \begin{code}
 444 tcMonoBinds :: RenamedMonoBinds
 445             -> [Name] -> [TcIdBndr s]
 446             -> [TcSigInfo s]
 447             -> TcM s (TcMonoBinds s, LIE s)
 448
 449 tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
 450   = tcExtendLocalValEnv binder_names mono_ids (
 451         tc_mono_binds mbind
 452     )
 453   where
 454     sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
 455     sig_ids   = [id   | (TySigInfo _   id _ _ _ _) <- tc_ty_sigs]
 456
 457     tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
 458
 459     tc_mono_binds (AndMonoBinds mb1 mb2)
 460       = tc_mono_binds mb1               `thenTc` \ (mb1a, lie1) ->
 461         tc_mono_binds mb2               `thenTc` \ (mb2a, lie2) ->
 462         returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
 463
 464     tc_mono_binds (FunMonoBind name inf matches locn)
 465       = tcAddSrcLoc locn                                $
 466         tcLookupLocalValueOK "tc_mono_binds" name       `thenNF_Tc` \ id ->
 467
 468                 -- Before checking the RHS, extend the envt with
 469                 -- bindings for the *polymorphic* Ids from any type signatures
 470         tcExtendLocalValEnv sig_names sig_ids           $
 471         tcMatchesFun name (idType id) matches           `thenTc` \ (matches', lie) ->
 472
 473         returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
 474
 475     tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
 476       = tcAddSrcLoc locn                        $
 477         tcAddErrCtxt (patMonoBindsCtxt bind)    $
 478         tcPat pat                               `thenTc` \ (pat2, lie_pat, pat_ty) ->
 479
 480                 -- Before checking the RHS, but after the pattern, extend the envt with
 481                 -- bindings for the *polymorphic* Ids from any type signatures
 482         tcExtendLocalValEnv sig_names sig_ids   $
 483         tcGRHSsAndBinds pat_ty grhss_and_binds  `thenTc` \ (grhss_and_binds2, lie) ->
 484         returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
 485                   plusLIE lie_pat lie)
 486 \end{code}
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection{Signatures}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 @tcSigs@ checks the signatures for validity, and returns a list of
 495 {\em freshly-instantiated} signatures.  That is, the types are already
 496 split up, and have fresh type variables installed.  All non-type-signature
 497 "RenamedSigs" are ignored.
 498
 499 The @TcSigInfo@ contains @TcTypes@ because they are unified with
 500 the variable's type, and after that checked to see whether they've
 501 been instantiated.
 502
 503 \begin{code}
 504 data TcSigInfo s
 505   = TySigInfo
 506         Name                    -- N, the Name in corresponding binding
 507         (TcIdBndr s)            -- *Polymorphic* binder for this value...
 508                                 -- Usually has name = N, but doesn't have to.
 509         [TcTyVar s]
 510         (TcThetaType s)
 511         (TcTauType s)
 512         SrcLoc
 513
 514
 515 maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
 516         -- Search for a particular signature
 517 maybeSig [] name = Nothing
 518 maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
 519   | name == sig_name = Just sig
 520   | otherwise        = maybeSig sigs name
 521 \end{code}
 522
 523
 524 \begin{code}
 525 tcTySig :: (Name -> PragmaInfo)
 526         -> RenamedSig
 527         -> TcM s (TcSigInfo s)
 528
 529 tcTySig prag_info_fn (Sig v ty src_loc)
 530  = tcAddSrcLoc src_loc $
 531    tcHsType ty                  `thenTc` \ sigma_ty ->
 532    tcInstSigType sigma_ty       `thenNF_Tc` \ sigma_ty' ->
 533    let
 534      poly_id = mkUserId v sigma_ty' (prag_info_fn v)
 535      (tyvars', theta', tau') = splitSigmaTy sigma_ty'
 536         -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
 537         -- wherever possible, which can improve interface files.
 538    in
 539    returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc)
 540 \end{code}
 541
 542 @checkSigMatch@ does the next step in checking signature matching.
 543 The tau-type part has already been unified.  What we do here is to
 544 check that this unification has not over-constrained the (polymorphic)
 545 type variables of the original signature type.
 546
 547 The error message here is somewhat unsatisfactory, but it'll do for
 548 now (ToDo).
 549
 550 \begin{code}
 551 checkSigMatch []
 552   = returnTc (error "checkSigMatch")
 553
 554 checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _) : all_sigs_but_first )
 555   =     -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
 556         -- Doesn't affect substitution
 557     mapTc check_one_sig tc_ty_sigs      `thenTc_`
 558
 559         -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
 560         -- The type signatures on a mutually-recursive group of definitions
 561         -- must all have the same context (or none).
 562         --
 563         -- We unify them because, with polymorphic recursion, their types
 564         -- might not otherwise be related.  This is a rather subtle issue.
 565         -- ToDo: amplify
 566     mapTc check_one_cxt all_sigs_but_first              `thenTc_`
 567
 568     returnTc theta1
 569   where
 570     sig1_dict_tys       = mk_dict_tys theta1
 571     n_sig1_dict_tys     = length sig1_dict_tys
 572
 573     check_one_cxt sig@(TySigInfo _ id _  theta _ src_loc)
 574        = tcAddSrcLoc src_loc    $
 575          tcAddErrCtxt (sigContextsCtxt id1 id) $
 576          checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
 577                                 sigContextsErr          `thenTc_`
 578          unifyTauTyLists sig1_dict_tys this_sig_dict_tys
 579       where
 580          this_sig_dict_tys = mk_dict_tys theta
 581
 582     check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
 583       = tcAddSrcLoc src_loc     $
 584         tcAddErrCtxt (sigCtxt id) $
 585         checkSigTyVars sig_tyvars sig_tau
 586
 587     mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta]
 588 \end{code}
 589
 590
 591 @checkSigTyVars@ is used after the type in a type signature has been unified with
 592 the actual type found.  It then checks that the type variables of the type signature
 593 are
 594         (a) still all type variables
 595                 eg matching signature [a] against inferred type [(p,q)]
 596                 [then a will be unified to a non-type variable]
 597
 598         (b) still all distinct
 599                 eg matching signature [(a,b)] against inferred type [(p,p)]
 600                 [then a and b will be unified together]
 601
 602 BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS
 603
 604         (c) not mentioned in the environment
 605                 eg the signature for f in this:
 606
 607                         g x = ... where
 608                                         f :: a->[a]
 609                                         f y = [x,y]
 610
 611                 Here, f is forced to be monorphic by the free occurence of x.
 612
 613 Before doing this, the substitution is applied to the signature type variable.
 614
 615 \begin{code}
 616 checkSigTyVars :: [TcTyVar s]           -- The original signature type variables
 617                -> TcType s              -- signature type (for err msg)
 618                -> TcM s ()
 619
 620 checkSigTyVars sig_tyvars sig_tau
 621   =     -- Several type signatures in the same bindings group can
 622         -- cause the signature type variable from the different
 623         -- signatures to be unified.  So we need to zonk them.
 624     mapNF_Tc zonkSigTyVar sig_tyvars    `thenNF_Tc` \ sig_tyvars' ->
 625
 626         -- Point (a) is forced by the fact that they are signature type
 627         -- variables, so the unifer won't bind them to a type.
 628
 629         -- Check point (b)
 630     checkTcM (hasNoDups sig_tyvars')
 631              (zonkTcType sig_tau        `thenNF_Tc` \ sig_tau' ->
 632               failTc (badMatchErr sig_tau sig_tau')
 633              )                          `thenTc_`
 634
 635         -- Check point (c)
 636         -- We want to report errors in terms of the original signature tyvars,
 637         -- ie sig_tyvars, NOT sig_tyvars'.  sig_tyvars' correspond
 638         -- 1-1 with sig_tyvars, so we can just map back.
 639     tcGetGlobalTyVars                   `thenNF_Tc` \ globals ->
 640     let
 641 --      mono_tyvars = [sig_tv | (sig_tv, sig_tv') <- sig_tyvars `zip` sig_tyvars',
 642 --                               sig_tv' `elementOfTyVarSet` globals
 643 --                    ]
 644         mono_tyvars' = [sig_tv' | sig_tv' <- sig_tyvars',
 645                                   sig_tv' `elementOfTyVarSet` globals]
 646     in
 647     checkTcM (null mono_tyvars')
 648              (zonkTcType sig_tau        `thenNF_Tc` \ sig_tau' ->
 649               failTc (notAsPolyAsSigErr sig_tau' mono_tyvars'))
 650 \end{code}
 651
 652
 653 %************************************************************************
 654 %*                                                                      *
 655 \subsection{SPECIALIZE pragmas}
 656 %*                                                                      *
 657 %************************************************************************
 658
 659
 660 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
 661 pragmas.  It is convenient for them to appear in the @[RenamedSig]@
 662 part of a binding because then the same machinery can be used for
 663 moving them into place as is done for type signatures.
 664
 665 \begin{code}
 666 tcPragmaSigs :: [RenamedSig]                    -- The pragma signatures
 667              -> TcM s (Name -> PragmaInfo,      -- Maps name to the appropriate PragmaInfo
 668                        TcMonoBinds s,
 669                        LIE s)
 670
 671 -- For now we just deal with INLINE pragmas
 672 tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
 673   where
 674     prag_fn name | any has_inline sigs = IWantToBeINLINEd
 675                  | otherwise           = NoPragmaInfo
 676                  where
 677                     has_inline (InlineSig n _) = (n == name)
 678                     has_inline other           = False
 679
 680
 681 {-
 682 tcPragmaSigs sigs
 683   = mapAndUnzip3Tc tcPragmaSig sigs     `thenTc` \ (names_w_id_infos, binds, lies) ->
 684     let
 685         name_to_info name = foldr ($) noIdInfo
 686                                   [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
 687     in
 688     returnTc (name_to_info,
 689               foldr ThenBinds EmptyBinds binds,
 690               foldr plusLIE emptyLIE lies)
 691 \end{code}
 692
 693 Here are the easy cases for tcPragmaSigs
 694
 695 \begin{code}
 696 tcPragmaSig (DeforestSig name loc)
 697   = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
 698 tcPragmaSig (InlineSig name loc)
 699   = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
 700 tcPragmaSig (MagicUnfoldingSig name string loc)
 701   = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
 702 \end{code}
 703
 704 The interesting case is for SPECIALISE pragmas.  There are two forms.
 705 Here's the first form:
 706 \begin{verbatim}
 707         f :: Ord a => [a] -> b -> b
 708         {-# SPECIALIZE f :: [Int] -> b -> b #-}
 709 \end{verbatim}
 710
 711 For this we generate:
 712 \begin{verbatim}
 713         f* = /\ b -> let d1 = ...
 714                      in f Int b d1
 715 \end{verbatim}
 716
 717 where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
 718 retain a right-hand-side that the simplifier will otherwise discard as
 719 dead code... the simplifier has a flag that tells it not to discard
 720 SpecPragmaId bindings.
 721
 722 In this case the f* retains a call-instance of the overloaded
 723 function, f, (including appropriate dictionaries) so that the
 724 specialiser will subsequently discover that there's a call of @f@ at
 725 Int, and will create a specialisation for @f@.  After that, the
 726 binding for @f*@ can be discarded.
 727
 728 The second form is this:
 729 \begin{verbatim}
 730         f :: Ord a => [a] -> b -> b
 731         {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
 732 \end{verbatim}
 733
 734 Here @g@ is specified as a function that implements the specialised
 735 version of @f@.  Suppose that g has type (a->b->b); that is, g's type
 736 is more general than that required.  For this we generate
 737 \begin{verbatim}
 738         f@Int = /\b -> g Int b
 739         f* = f@Int
 740 \end{verbatim}
 741
 742 Here @f@@Int@ is a SpecId, the specialised version of @f@.  It inherits
 743 f's export status etc.  @f*@ is a SpecPragmaId, as before, which just serves
 744 to prevent @f@@Int@ from being discarded prematurely.  After specialisation,
 745 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
 746 discard the f* binding.
 747
 748 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
 749 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
 750 a bit of overkill.
 751
 752 \begin{code}
 753 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 754   = tcAddSrcLoc src_loc                         $
 755     tcAddErrCtxt (valSpecSigCtxt name spec_ty)  $
 756
 757         -- Get and instantiate its alleged specialised type
 758     tcHsType poly_ty                            `thenTc` \ sig_sigma ->
 759     tcInstSigType  sig_sigma                    `thenNF_Tc` \ sig_ty ->
 760     let
 761         (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
 762         origin = ValSpecOrigin name
 763     in
 764
 765         -- Check that the SPECIALIZE pragma had an empty context
 766     checkTc (null sig_theta)
 767             (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
 768
 769         -- Get and instantiate the type of the id mentioned
 770     tcLookupLocalValueOK "tcPragmaSig" name     `thenNF_Tc` \ main_id ->
 771     tcInstSigType [] (idType main_id)           `thenNF_Tc` \ main_ty ->
 772     let
 773         (main_tyvars, main_rho) = splitForAllTy main_ty
 774         (main_theta,main_tau)   = splitRhoTy main_rho
 775         main_arg_tys            = mkTyVarTys main_tyvars
 776     in
 777
 778         -- Check that the specialised type is indeed an instance of
 779         -- the type of the main function.
 780     unifyTauTy sig_tau main_tau         `thenTc_`
 781     checkSigTyVars sig_tyvars sig_tau   `thenTc_`
 782
 783         -- Check that the type variables of the polymorphic function are
 784         -- either left polymorphic, or instantiate to ground type.
 785         -- Also check that the overloaded type variables are instantiated to
 786         -- ground type; or equivalently that all dictionaries have ground type
 787     mapTc zonkTcType main_arg_tys       `thenNF_Tc` \ main_arg_tys' ->
 788     zonkTcThetaType main_theta          `thenNF_Tc` \ main_theta' ->
 789     tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
 790               (checkTc (all isGroundOrTyVarTy main_arg_tys'))           `thenTc_`
 791     tcAddErrCtxt (specContextGroundnessCtxt main_theta')
 792               (checkTc (and [isGroundTy ty | (_,ty) <- theta']))        `thenTc_`
 793
 794         -- Build the SpecPragmaId; it is the thing that makes sure we
 795         -- don't prematurely dead-code-eliminate the binding we are really interested in.
 796     newSpecPragmaId name sig_ty         `thenNF_Tc` \ spec_pragma_id ->
 797
 798         -- Build a suitable binding; depending on whether we were given
 799         -- a value (Maybe Name) to be used as the specialisation.
 800     case using of
 801       Nothing ->                -- No implementation function specified
 802
 803                 -- Make a Method inst for the occurrence of the overloaded function
 804         newMethodWithGivenTy (OccurrenceOf name)
 805                   (TcId main_id) main_arg_tys main_rho  `thenNF_Tc` \ (lie, meth_id) ->
 806
 807         let
 808             pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
 809             pseudo_rhs  = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
 810         in
 811         returnTc (pseudo_bind, lie, \ info -> info)
 812
 813       Just spec_name ->         -- Use spec_name as the specialisation value ...
 814
 815                 -- Type check a simple occurrence of the specialised Id
 816         tcId spec_name          `thenTc` \ (spec_body, spec_lie, spec_tau) ->
 817
 818                 -- Check that it has the correct type, and doesn't constrain the
 819                 -- signature variables at all
 820         unifyTauTy sig_tau spec_tau             `thenTc_`
 821         checkSigTyVars sig_tyvars sig_tau       `thenTc_`
 822
 823             -- Make a local SpecId to bind to applied spec_id
 824         newSpecId main_id main_arg_tys sig_ty   `thenNF_Tc` \ local_spec_id ->
 825
 826         let
 827             spec_rhs   = mkHsTyLam sig_tyvars spec_body
 828             spec_binds = VarMonoBind local_spec_id spec_rhs
 829                            `AndMonoBinds`
 830                          VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
 831             spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
 832         in
 833         returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
 834 -}
 835 \end{code}
 836
 837
 838 %************************************************************************
 839 %*                                                                      *
 840 \subsection[TcBinds-errors]{Error contexts and messages}
 841 %*                                                                      *
 842 %************************************************************************
 843
 844
 845 \begin{code}
 846 patMonoBindsCtxt bind sty
 847   = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind)
 848
 849 -----------------------------------------------
 850 valSpecSigCtxt v ty sty
 851   = hang (ptext SLIT("In a SPECIALIZE pragma for a value:"))
 852          4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")),
 853                   ppr sty ty])
 854
 855
 856
 857 -----------------------------------------------
 858 notAsPolyAsSigErr sig_tau mono_tyvars sty
 859   = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
 860         4  (vcat [text "Can't for-all the type variable(s)" <+> interpp'SP sty mono_tyvars,
 861                   text "in the inferred type" <+> ppr sty sig_tau
 862            ])
 863
 864 -----------------------------------------------
 865 badMatchErr sig_ty inferred_ty sty
 866   = hang (ptext SLIT("Type signature doesn't match inferred type"))
 867          4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty),
 868                       hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty)
 869            ])
 870
 871 -----------------------------------------------
 872 sigCtxt id sty
 873   = sep [ptext SLIT("When checking signature for"), ppr sty id]
 874 sigsCtxt ids sty
 875   = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids]
 876
 877 -----------------------------------------------
 878 sigContextsErr sty
 879   = ptext SLIT("Mismatched contexts")
 880 sigContextsCtxt s1 s2 sty
 881   = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
 882                 ppr sty s1, ptext SLIT("and"), ppr sty s2])
 883          4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
 884
 885 -----------------------------------------------
 886 specGroundnessCtxt
 887   = panic "specGroundnessCtxt"
 888
 889 --------------------------------------------
 890 specContextGroundnessCtxt -- err_ctxt dicts sty
 891   = panic "specContextGroundnessCtxt"
 892 {-
 893   = hang (
 894         sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name],
 895              hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty],
 896              pp_spec_id sty,
 897              ptext SLIT("... not all overloaded type variables were instantiated"),
 898              ptext SLIT("to ground types:")])
 899       4 (vcat [hsep [ppr sty c, ppr sty t]
 900                   | (c,t) <- map getDictClassAndType dicts])
 901   where
 902     (name, spec_ty, locn, pp_spec_id)
 903       = case err_ctxt of
 904           ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> empty)
 905           ValSpecSpecIdCtxt n ty spec loc ->
 906             (n, ty, loc,
 907              \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec])
 908 -}
 909 \end{code}
 910
 911
 912
 913