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