compiler/typecheck/TcBinds.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[TcBinds]{TcBinds}
   6
   7 \begin{code}
   8 module TcBinds ( tcLocalBinds, tcTopBinds,
   9                  tcHsBootSigs, tcMonoBinds,
  10                  TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
  11                  TcSigInfo(..), TcSigFun, mkTcSigFun,
  12                  badBootDeclErr ) where
  13
  14 #include "HsVersions.h"
  15
  16 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
  17 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
  18
  19 import DynFlags
  20 import HsSyn
  21 import TcHsSyn
  22
  23 import TcRnMonad
  24 import Inst
  25 import TcEnv
  26 import TcUnify
  27 import TcSimplify
  28 import TcHsType
  29 import TcPat
  30 import TcMType
  31 import TcType
  32 import {- Kind parts of -} Type
  33 import VarEnv
  34 import TysPrim
  35 import Id
  36 import IdInfo
  37 import Var ( TyVar )
  38 import Name
  39 import NameSet
  40 import NameEnv
  41 import VarSet
  42 import SrcLoc
  43 import Bag
  44 import ErrUtils
  45 import Digraph
  46 import Maybes
  47 import Util
  48 import BasicTypes
  49 import Outputable
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{Type-checking bindings}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 @tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
  60 it needs to know something about the {\em usage} of the things bound,
  61 so that it can create specialisations of them.  So @tcBindsAndThen@
  62 takes a function which, given an extended environment, E, typechecks
  63 the scope of the bindings returning a typechecked thing and (most
  64 important) an LIE.  It is this LIE which is then used as the basis for
  65 specialising the things bound.
  66
  67 @tcBindsAndThen@ also takes a "combiner" which glues together the
  68 bindings and the "thing" to make a new "thing".
  69
  70 The real work is done by @tcBindWithSigsAndThen@.
  71
  72 Recursive and non-recursive binds are handled in essentially the same
  73 way: because of uniques there are no scoping issues left.  The only
  74 difference is that non-recursive bindings can bind primitive values.
  75
  76 Even for non-recursive binding groups we add typings for each binder
  77 to the LVE for the following reason.  When each individual binding is
  78 checked the type of its LHS is unified with that of its RHS; and
  79 type-checking the LHS of course requires that the binder is in scope.
  80
  81 At the top-level the LIE is sure to contain nothing but constant
  82 dictionaries, which we resolve at the module level.
  83
  84 \begin{code}
  85 tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
  86         -- Note: returning the TcLclEnv is more than we really
  87         --       want.  The bit we care about is the local bindings
  88         --       and the free type variables thereof
  89 tcTopBinds binds
  90   = do  { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
  91         ; return (foldr (unionBags . snd) emptyBag prs, env) }
  92         -- The top level bindings are flattened into a giant
  93         -- implicitly-mutually-recursive LHsBinds
  94
  95 tcHsBootSigs :: HsValBinds Name -> TcM [Id]
  96 -- A hs-boot file has only one BindGroup, and it only has type
  97 -- signatures in it.  The renamer checked all this
  98 tcHsBootSigs (ValBindsOut binds sigs)
  99   = do  { checkTc (null binds) badBootDeclErr
 100         ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
 101   where
 102     tc_boot_sig (TypeSig (L _ name) ty)
 103       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
 104            ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
 105         -- Notice that we make GlobalIds, not LocalIds
 106 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
 107
 108 badBootDeclErr :: Message
 109 badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
 110
 111 ------------------------
 112 tcLocalBinds :: HsLocalBinds Name -> TcM thing
 113              -> TcM (HsLocalBinds TcId, thing)
 114
 115 tcLocalBinds EmptyLocalBinds thing_inside
 116   = do  { thing <- thing_inside
 117         ; return (EmptyLocalBinds, thing) }
 118
 119 tcLocalBinds (HsValBinds binds) thing_inside
 120   = do  { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
 121         ; return (HsValBinds binds', thing) }
 122
 123 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
 124   = do  { (thing, lie) <- getLIE thing_inside
 125         ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
 126
 127         -- If the binding binds ?x = E, we  must now
 128         -- discharge any ?x constraints in expr_lie
 129         ; dict_binds <- tcSimplifyIPs avail_ips lie
 130         ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) }
 131   where
 132         -- I wonder if we should do these one at at time
 133         -- Consider     ?x = 4
 134         --              ?y = ?x + 1
 135     tc_ip_bind (IPBind ip expr)
 136       = newFlexiTyVarTy argTypeKind             `thenM` \ ty ->
 137         newIPDict (IPBindOrigin ip) ip ty       `thenM` \ (ip', ip_inst) ->
 138         tcMonoExpr expr ty                      `thenM` \ expr' ->
 139         returnM (ip_inst, (IPBind ip' expr'))
 140
 141 ------------------------
 142 tcValBinds :: TopLevelFlag
 143            -> HsValBinds Name -> TcM thing
 144            -> TcM (HsValBinds TcId, thing)
 145
 146 tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
 147   = pprPanic "tcValBinds" (ppr binds)
 148
 149 tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
 150   = do  {       -- Typecheck the signature
 151         ; let { prag_fn = mkPragFun sigs
 152               ; ty_sigs = filter isVanillaLSig sigs
 153               ; sig_fn  = mkTcSigFun ty_sigs }
 154
 155         ; poly_ids <- mapM tcTySig ty_sigs
 156                 -- No recovery from bad signatures, because the type sigs
 157                 -- may bind type variables, so proceeding without them
 158                 -- can lead to a cascade of errors
 159                 -- ToDo: this means we fall over immediately if any type sig
 160                 -- is wrong, which is over-conservative, see Trac bug #745
 161
 162                 -- Extend the envt right away with all
 163                 -- the Ids declared with type signatures
 164         ; gla_exts     <- doptM Opt_GlasgowExts
 165         ; (binds', thing) <- tcExtendIdEnv poly_ids $
 166                              tc_val_binds gla_exts top_lvl sig_fn prag_fn
 167                                           binds thing_inside
 168
 169         ; return (ValBindsOut binds' sigs, thing) }
 170
 171 ------------------------
 172 tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
 173              -> [(RecFlag, LHsBinds Name)] -> TcM thing
 174              -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 175 -- Typecheck a whole lot of value bindings,
 176 -- one strongly-connected component at a time
 177
 178 tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside
 179   = do  { thing <- thing_inside
 180         ; return ([], thing) }
 181
 182 tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside
 183   = do  { (group', (groups', thing))
 184                 <- tc_group gla_exts top_lvl sig_fn prag_fn group $
 185                    tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside
 186         ; return (group' ++ groups', thing) }
 187
 188 ------------------------
 189 tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
 190          -> (RecFlag, LHsBinds Name) -> TcM thing
 191          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 192
 193 -- Typecheck one strongly-connected component of the original program.
 194 -- We get a list of groups back, because there may
 195 -- be specialisations etc as well
 196
 197 tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
 198         -- A single non-recursive binding
 199         -- We want to keep non-recursive things non-recursive
 200         -- so that we desugar unlifted bindings correctly
 201  =  do  { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside
 202         ; return ([(NonRecursive, b) | b <- binds], thing) }
 203
 204 tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
 205   | not gla_exts        -- Recursive group, normal Haskell 98 route
 206   = do  { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside
 207         ; return ([(Recursive, unionManyBags binds1)], thing) }
 208
 209   | otherwise           -- Recursive group, with gla-exts
 210   =     -- To maximise polymorphism (with -fglasgow-exts), we do a new
 211         -- strongly-connected-component analysis, this time omitting
 212         -- any references to variables with type signatures.
 213         --
 214         -- Notice that the bindInsts thing covers *all* the bindings in the original
 215         -- group at once; an earlier one may use a later one!
 216     do  { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
 217         ; (binds1,thing) <- bindLocalInsts top_lvl $
 218                             go (stronglyConnComp (mkEdges sig_fn binds))
 219         ; return ([(Recursive, unionManyBags binds1)], thing) }
 220                 -- Rec them all together
 221   where
 222 --  go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], [TcId], thing)
 223     go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
 224                         ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs
 225                         ; return (binds1 ++ binds2, ids1 ++ ids2, thing) }
 226     go []         = do  { thing <- thing_inside; return ([], [], thing) }
 227
 228     tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive (unitBag bind)
 229     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    (listToBag binds)
 230
 231     tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
 232
 233 tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside
 234   = bindLocalInsts top_lvl $ do
 235     { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds
 236     ; thing <- tcExtendIdEnv ids thing_inside
 237     ; return (binds1, ids, thing) }
 238
 239 ------------------------
 240 bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a)
 241 bindLocalInsts top_lvl thing_inside
 242   | isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) }
 243         -- For the top level don't bother will all this bindInstsOfLocalFuns stuff.
 244         -- All the top level things are rec'd together anyway, so it's fine to
 245         -- leave them to the tcSimplifyTop, and quite a bit faster too
 246
 247   | otherwise   -- Nested case
 248   = do  { ((binds, ids, thing), lie) <- getLIE thing_inside
 249         ; lie_binds <- bindInstsOfLocalFuns lie ids
 250         ; return (binds ++ [lie_binds], thing) }
 251
 252 ------------------------
 253 mkEdges :: TcSigFun -> LHsBinds Name
 254         -> [(LHsBind Name, BKey, [BKey])]
 255
 256 type BKey  = Int -- Just number off the bindings
 257
 258 mkEdges sig_fn binds
 259   = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
 260                          Just key <- [lookupNameEnv key_map n], no_sig n ])
 261     | (bind, key) <- keyd_binds
 262     ]
 263   where
 264     no_sig :: Name -> Bool
 265     no_sig n = isNothing (sig_fn n)
 266
 267     keyd_binds = bagToList binds `zip` [0::BKey ..]
 268
 269     key_map :: NameEnv BKey     -- Which binding it comes from
 270     key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
 271                                      , bndr <- bindersOfHsBind bind ]
 272
 273 bindersOfHsBind :: HsBind Name -> [Name]
 274 bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
 275 bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
 276
 277 ------------------------
 278 tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun
 279             -> RecFlag                  -- Whether the group is really recursive
 280             -> RecFlag                  -- Whether it's recursive after breaking
 281                                         -- dependencies based on type signatures
 282             -> LHsBinds Name
 283             -> TcM ([LHsBinds TcId], [TcId])
 284
 285 -- Typechecks a single bunch of bindings all together,
 286 -- and generalises them.  The bunch may be only part of a recursive
 287 -- group, because we use type signatures to maximise polymorphism
 288 --
 289 -- Returns a list because the input may be a single non-recursive binding,
 290 -- in which case the dependency order of the resulting bindings is
 291 -- important.
 292 --
 293 -- Knows nothing about the scope of the bindings
 294
 295 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 296   = let
 297         bind_list    = bagToList binds
 298         binder_names = collectHsBindBinders binds
 299         loc          = getLoc (head bind_list)
 300                 -- TODO: location a bit awkward, but the mbinds have been
 301                 --       dependency analysed and may no longer be adjacent
 302     in
 303         -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
 304     setSrcSpan loc                              $
 305     recoverM (recoveryCode binder_names sig_fn) $ do
 306
 307   { traceTc (ptext SLIT("------------------------------------------------"))
 308   ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
 309
 310         -- TYPECHECK THE BINDINGS
 311   ; ((binds', mono_bind_infos), lie_req)
 312         <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
 313
 314         -- CHECK FOR UNLIFTED BINDINGS
 315         -- These must be non-recursive etc, and are not generalised
 316         -- They desugar to a case expression in the end
 317   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
 318   ; is_strict <- checkStrictBinds top_lvl rec_group binds'
 319                                   zonked_mono_tys mono_bind_infos
 320   ; if is_strict then
 321     do  { extendLIEs lie_req
 322         ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
 323               mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
 324               mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig,             mono_id, [])
 325                         -- ToDo: prags for unlifted bindings
 326
 327         ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
 328                    [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
 329
 330     else do     -- The normal lifted case: GENERALISE
 331   { dflags <- getDOpts
 332   ; (tyvars_to_gen, dict_binds, dict_ids)
 333         <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
 334            generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
 335
 336         -- FINALISE THE QUANTIFIED TYPE VARIABLES
 337         -- The quantified type variables often include meta type variables
 338         -- we want to freeze them into ordinary type variables, and
 339         -- default their kind (e.g. from OpenTypeKind to TypeKind)
 340   ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
 341
 342         -- BUILD THE POLYMORPHIC RESULT IDs
 343   ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
 344                     mono_bind_infos
 345
 346   ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
 347   ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
 348
 349   ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
 350                                     dict_ids exports
 351                                     (dict_binds `unionBags` binds')
 352
 353   ; return ([unitBag abs_bind], poly_ids)       -- poly_ids are guaranteed zonked by mkExport
 354   } }
 355
 356
 357 --------------
 358 mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
 359          -> TcM ([TyVar], Id, Id, [Prag])
 360 -- mkExport generates exports with
 361 --      zonked type variables,
 362 --      zonked poly_ids
 363 -- The former is just because no further unifications will change
 364 -- the quantified type variables, so we can fix their final form
 365 -- right now.
 366 -- The latter is needed because the poly_ids are used to extend the
 367 -- type environment; see the invariant on TcEnv.tcExtendIdEnv
 368
 369 -- Pre-condition: the inferred_tvs are already zonked
 370
 371 mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
 372   = do  { (tvs, poly_id) <- mk_poly_id mb_sig
 373
 374         ; poly_id' <- zonkId poly_id
 375         ; prags <- tcPrags poly_id' (prag_fn poly_name)
 376                 -- tcPrags requires a zonked poly_id
 377
 378         ; return (tvs, poly_id', mono_id, prags) }
 379   where
 380     poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
 381
 382     mk_poly_id Nothing    = return (inferred_tvs, mkLocalId poly_name poly_ty)
 383     mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
 384                                ; return (tvs,  sig_id sig) }
 385
 386     zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
 387
 388 ------------------------
 389 type TcPragFun = Name -> [LSig Name]
 390
 391 mkPragFun :: [LSig Name] -> TcPragFun
 392 mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
 393         where
 394           prs = [(expectJust "mkPragFun" (sigName sig), sig)
 395                 | sig <- sigs, isPragLSig sig]
 396           env = foldl add emptyNameEnv prs
 397           add env (n,p) = extendNameEnv_Acc (:) singleton env n p
 398
 399 tcPrags :: Id -> [LSig Name] -> TcM [Prag]
 400 tcPrags poly_id prags = mapM tc_prag prags
 401   where
 402     tc_prag (L loc prag) = setSrcSpan loc $
 403                            addErrCtxt (pragSigCtxt prag) $
 404                            tcPrag poly_id prag
 405
 406 pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
 407
 408 tcPrag :: TcId -> Sig Name -> TcM Prag
 409 -- Pre-condition: the poly_id is zonked
 410 -- Reason: required by tcSubExp
 411 tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl
 412 tcPrag poly_id (SpecInstSig hs_ty)           = tcSpecPrag poly_id hs_ty defaultInlineSpec
 413 tcPrag poly_id (InlineSig v inl)             = return (InlinePrag inl)
 414
 415
 416 tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
 417 tcSpecPrag poly_id hs_ty inl
 418   = do  { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
 419         ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
 420         ; extendLIEs lie
 421         ; let const_dicts = map instToId lie
 422         ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
 423         -- Most of the work of specialisation is done by
 424         -- the desugarer, guided by the SpecPrag
 425
 426 --------------
 427 -- If typechecking the binds fails, then return with each
 428 -- signature-less binder given type (forall a.a), to minimise
 429 -- subsequent error messages
 430 recoveryCode binder_names sig_fn
 431   = do  { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
 432         ; poly_ids <- mapM mk_dummy binder_names
 433         ; return ([], poly_ids) }
 434   where
 435     mk_dummy name
 436         | isJust (sig_fn name) = tcLookupId name        -- Had signature; look it up
 437         | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
 438
 439 forall_a_a :: TcType
 440 forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
 441
 442
 443 -- Check that non-overloaded unlifted bindings are
 444 --      a) non-recursive,
 445 --      b) not top level,
 446 --      c) not a multiple-binding group (more or less implied by (a))
 447
 448 checkStrictBinds :: TopLevelFlag -> RecFlag
 449                  -> LHsBinds TcId -> [TcType] -> [MonoBindInfo]
 450                  -> TcM Bool
 451 checkStrictBinds top_lvl rec_group mbind mono_tys infos
 452   | unlifted || bang_pat
 453   = do  { checkTc (isNotTopLevel top_lvl)
 454                   (strictBindErr "Top-level" unlifted mbind)
 455         ; checkTc (isNonRec rec_group)
 456                   (strictBindErr "Recursive" unlifted mbind)
 457         ; checkTc (isSingletonBag mbind)
 458                   (strictBindErr "Multiple" unlifted mbind)
 459         ; mapM_ check_sig infos
 460         ; return True }
 461   | otherwise
 462   = return False
 463   where
 464     unlifted = any isUnLiftedType mono_tys
 465     bang_pat = anyBag (isBangHsBind . unLoc) mbind
 466     check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
 467                                          (badStrictSig unlifted sig)
 468     check_sig other            = return ()
 469
 470 strictBindErr flavour unlifted mbind
 471   = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:"))
 472          4 (pprLHsBinds mbind)
 473   where
 474     msg | unlifted  = ptext SLIT("bindings for unlifted types")
 475         | otherwise = ptext SLIT("bang-pattern bindings")
 476
 477 badStrictSig unlifted sig
 478   = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg)
 479          4 (ppr sig)
 480   where
 481     msg | unlifted  = ptext SLIT("an unlifted binding")
 482         | otherwise = ptext SLIT("a bang-pattern binding")
 483 \end{code}
 484
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection{tcMonoBind}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
 493 The signatures have been dealt with already.
 494
 495 \begin{code}
 496 tcMonoBinds :: [LHsBind Name]
 497             -> TcSigFun
 498             -> RecFlag  -- Whether the binding is recursive for typechecking purposes
 499                         -- i.e. the binders are mentioned in their RHSs, and
 500                         --      we are not resuced by a type signature
 501             -> TcM (LHsBinds TcId, [MonoBindInfo])
 502
 503 tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
 504                                 fun_matches = matches, bind_fvs = fvs })]
 505             sig_fn              -- Single function binding,
 506             NonRecursive        -- binder isn't mentioned in RHS,
 507   | Nothing <- sig_fn name      -- ...with no type signature
 508   =     -- In this very special case we infer the type of the
 509         -- right hand side first (it may have a higher-rank type)
 510         -- and *then* make the monomorphic Id for the LHS
 511         -- e.g.         f = \(x::forall a. a->a) -> <body>
 512         --      We want to infer a higher-rank type for f
 513     setSrcSpan b_loc    $
 514     do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
 515
 516                 -- Check for an unboxed tuple type
 517                 --      f = (# True, False #)
 518                 -- Zonk first just in case it's hidden inside a meta type variable
 519                 -- (This shows up as a (more obscure) kind error
 520                 --  in the 'otherwise' case of tcMonoBinds.)
 521         ; zonked_rhs_ty <- zonkTcType rhs_ty
 522         ; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
 523                   (unboxedTupleErr name zonked_rhs_ty)
 524
 525         ; mono_name <- newLocalName name
 526         ; let mono_id = mkLocalId mono_name zonked_rhs_ty
 527         ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
 528                                               fun_matches = matches', bind_fvs = fvs,
 529                                               fun_co_fn = co_fn })),
 530                   [(name, Nothing, mono_id)]) }
 531
 532 tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
 533                                 fun_matches = matches, bind_fvs = fvs })]
 534             sig_fn              -- Single function binding
 535             non_rec
 536   | Just scoped_tvs <- sig_fn name      -- ...with a type signature
 537   =     -- When we have a single function binding, with a type signature
 538         -- we can (a) use genuine, rigid skolem constants for the type variables
 539         --        (b) bring (rigid) scoped type variables into scope
 540     setSrcSpan b_loc    $
 541     do  { tc_sig <- tcInstSig True name scoped_tvs
 542         ; mono_name <- newLocalName name
 543         ; let mono_ty = sig_tau tc_sig
 544               mono_id = mkLocalId mono_name mono_ty
 545               rhs_tvs = [ (name, mkTyVarTy tv)
 546                         | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
 547
 548         ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs    $
 549                                tcMatchesFun mono_name matches mono_ty
 550
 551         ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
 552                                     fun_infix = inf, fun_matches = matches',
 553                                     bind_fvs = placeHolderNames, fun_co_fn = co_fn }
 554         ; return (unitBag (L b_loc fun_bind'),
 555                   [(name, Just tc_sig, mono_id)]) }
 556
 557 tcMonoBinds binds sig_fn non_rec
 558   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
 559
 560         -- Bring the monomorphic Ids, into scope for the RHSs
 561         ; let mono_info  = getMonoBindInfo tc_binds
 562               rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
 563                                 -- A monomorphic binding for each term variable that lacks
 564                                 -- a type sig.  (Ones with a sig are already in scope.)
 565
 566         ; binds' <- tcExtendIdEnv2    rhs_id_env $
 567                     traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
 568                                                          | (n,id) <- rhs_id_env]) `thenM_`
 569                     mapM (wrapLocM tcRhs) tc_binds
 570         ; return (listToBag binds', mono_info) }
 571
 572 ------------------------
 573 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
 574 -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
 575 --      if there's a signature for it, use the instantiated signature type
 576 --      otherwise invent a type variable
 577 -- You see that quite directly in the FunBind case.
 578 --
 579 -- But there's a complication for pattern bindings:
 580 --      data T = MkT (forall a. a->a)
 581 --      MkT f = e
 582 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
 583 -- but we want to get (f::forall a. a->a) as the RHS environment.
 584 -- The simplest way to do this is to typecheck the pattern, and then look up the
 585 -- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
 586 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
 587
 588 data TcMonoBind         -- Half completed; LHS done, RHS not done
 589   = TcFunBind  MonoBindInfo  (Located TcId) Bool (MatchGroup Name)
 590   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
 591
 592 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
 593         -- Type signature (if any), and
 594         -- the monomorphic bound things
 595
 596 bndrNames :: [MonoBindInfo] -> [Name]
 597 bndrNames mbi = [n | (n,_,_) <- mbi]
 598
 599 getMonoType :: MonoBindInfo -> TcTauType
 600 getMonoType (_,_,mono_id) = idType mono_id
 601
 602 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
 603 tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
 604   = do  { mb_sig <- tcInstSig_maybe sig_fn name
 605         ; mono_name <- newLocalName name
 606         ; mono_ty   <- mk_mono_ty mb_sig
 607         ; let mono_id = mkLocalId mono_name mono_ty
 608         ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
 609   where
 610     mk_mono_ty (Just sig) = return (sig_tau sig)
 611     mk_mono_ty Nothing    = newFlexiTyVarTy argTypeKind
 612
 613 tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
 614   = do  { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names
 615         ; mono_pat_binds <- doptM Opt_MonoPatBinds
 616                 -- With -fmono-pat-binds, we do no generalisation of pattern bindings
 617                 -- But the signature can still be polymoprhic!
 618                 --      data T = MkT (forall a. a->a)
 619                 --      x :: forall a. a->a
 620                 --      MkT x = <rhs>
 621                 -- The function get_sig_ty decides whether the pattern-bound variables
 622                 -- should have exactly the type in the type signature (-fmono-pat-binds),
 623                 -- or the instantiated version (-fmono-pat-binds)
 624
 625         ; let nm_sig_prs  = names `zip` mb_sigs
 626               get_sig_ty | mono_pat_binds = idType . sig_id
 627                          | otherwise      = sig_tau
 628               tau_sig_env = mkNameEnv [ (name, get_sig_ty sig)
 629                                       | (name, Just sig) <- nm_sig_prs]
 630               sig_tau_fn  = lookupNameEnv tau_sig_env
 631
 632               tc_pat exp_ty = tcLetPat sig_tau_fn pat exp_ty $
 633                               mapM lookup_info nm_sig_prs
 634
 635                 -- After typechecking the pattern, look up the binder
 636                 -- names, which the pattern has brought into scope.
 637               lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo
 638               lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name
 639                                               ; return (name, mb_sig, mono_id) }
 640
 641         ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
 642                                      tcInfer tc_pat
 643
 644         ; return (TcPatBind infos pat' grhss pat_ty) }
 645   where
 646     names = collectPatBinders pat
 647
 648
 649 tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
 650         -- AbsBind, VarBind impossible
 651
 652 -------------------
 653 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 654 tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
 655   = do  { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches
 656                                             (idType mono_id)
 657         ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
 658                             bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
 659
 660 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
 661   = do  { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
 662                     tcGRHSsPat grhss pat_ty
 663         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty,
 664                             bind_fvs = placeHolderNames }) }
 665
 666
 667 ---------------------
 668 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
 669 getMonoBindInfo tc_binds
 670   = foldr (get_info . unLoc) [] tc_binds
 671   where
 672     get_info (TcFunBind info _ _ _)  rest = info : rest
 673     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
 674 \end{code}
 675
 676
 677 %************************************************************************
 678 %*                                                                      *
 679                 Generalisation
 680 %*                                                                      *
 681 %************************************************************************
 682
 683 \begin{code}
 684 generalise :: DynFlags -> TopLevelFlag
 685            -> [LHsBind Name] -> TcSigFun
 686            -> [MonoBindInfo] -> [Inst]
 687            -> TcM ([TcTyVar], TcDictBinds, [TcId])
 688 generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
 689   | isMonoGroup dflags bind_list
 690   = do { extendLIEs lie_req; return ([], emptyBag, []) }
 691
 692   | isRestrictedGroup dflags bind_list sig_fn   -- RESTRICTED CASE
 693   =     -- Check signature contexts are empty
 694     do  { checkTc (all is_mono_sig sigs)
 695                   (restrictedBindCtxtErr bndrs)
 696
 697         -- Now simplify with exactly that set of tyvars
 698         -- We have to squash those Methods
 699         ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs
 700                                                 tau_tvs lie_req
 701
 702         -- Check that signature type variables are OK
 703         ; final_qtvs <- checkSigsTyVars qtvs sigs
 704
 705         ; return (final_qtvs, binds, []) }
 706
 707   | null sigs   -- UNRESTRICTED CASE, NO TYPE SIGS
 708   = tcSimplifyInfer doc tau_tvs lie_req
 709
 710   | otherwise   -- UNRESTRICTED CASE, WITH TYPE SIGS
 711   = do  { sig_lie <- unifyCtxts sigs    -- sigs is non-empty
 712         ; let   -- The "sig_avails" is the stuff available.  We get that from
 713                 -- the context of the type signature, BUT ALSO the lie_avail
 714                 -- so that polymorphic recursion works right (see Note [Polymorphic recursion])
 715                 local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
 716                 sig_avails = sig_lie ++ local_meths
 717
 718         -- Check that the needed dicts can be
 719         -- expressed in terms of the signature ones
 720         ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
 721
 722         -- Check that signature type variables are OK
 723         ; final_qtvs <- checkSigsTyVars forall_tvs sigs
 724
 725         ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
 726   where
 727     bndrs   = bndrNames mono_infos
 728     sigs    = [sig | (_, Just sig, _) <- mono_infos]
 729     tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos
 730                 -- NB: exactTyVarsOfType; see Note [Silly type synonym]
 731                 --     near defn of TcType.exactTyVarsOfType
 732     is_mono_sig sig = null (sig_theta sig)
 733     doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs
 734
 735     mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
 736                             sig_theta = theta, sig_loc = loc }) mono_id
 737       = Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs,
 738                 tci_theta = theta, tci_loc = loc}
 739 \end{code}
 740
 741 unifyCtxts checks that all the signature contexts are the same
 742 The type signatures on a mutually-recursive group of definitions
 743 must all have the same context (or none).
 744
 745 The trick here is that all the signatures should have the same
 746 context, and we want to share type variables for that context, so that
 747 all the right hand sides agree a common vocabulary for their type
 748 constraints
 749
 750 We unify them because, with polymorphic recursion, their types
 751 might not otherwise be related.  This is a rather subtle issue.
 752
 753 \begin{code}
 754 unifyCtxts :: [TcSigInfo] -> TcM [Inst]
 755 unifyCtxts (sig1 : sigs)        -- Argument is always non-empty
 756   = do  { mapM unify_ctxt sigs
 757         ; newDictBndrs (sig_loc sig1) (sig_theta sig1) }
 758   where
 759     theta1 = sig_theta sig1
 760     unify_ctxt :: TcSigInfo -> TcM ()
 761     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
 762         = setSrcSpan (instLocSrcSpan (sig_loc sig))     $
 763           addErrCtxt (sigContextsCtxt sig1 sig)         $
 764           unifyTheta theta1 theta
 765
 766 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
 767 checkSigsTyVars qtvs sigs
 768   = do  { gbl_tvs <- tcGetGlobalTyVars
 769         ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs
 770
 771         ; let   -- Sigh.  Make sure that all the tyvars in the type sigs
 772                 -- appear in the returned ty var list, which is what we are
 773                 -- going to generalise over.  Reason: we occasionally get
 774                 -- silly types like
 775                 --      type T a = () -> ()
 776                 --      f :: T a
 777                 --      f () = ()
 778                 -- Here, 'a' won't appear in qtvs, so we have to add it
 779                 sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
 780                 all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
 781         ; returnM all_tvs }
 782   where
 783     check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs,
 784                                   sig_theta = theta, sig_tau = tau})
 785       = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id))        $
 786         addErrCtxtM (sigCtxt id tvs theta tau)                                          $
 787         do { tvs' <- checkDistinctTyVars tvs
 788            ; ifM (any (`elemVarSet` gbl_tvs) tvs')
 789                  (bleatEscapedTvs gbl_tvs tvs tvs')
 790            ; return tvs' }
 791
 792 checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
 793 -- (checkDistinctTyVars tvs) checks that the tvs from one type signature
 794 -- are still all type variables, and all distinct from each other.
 795 -- It returns a zonked set of type variables.
 796 -- For example, if the type sig is
 797 --      f :: forall a b. a -> b -> b
 798 -- we want to check that 'a' and 'b' haven't
 799 --      (a) been unified with a non-tyvar type
 800 --      (b) been unified with each other (all distinct)
 801
 802 checkDistinctTyVars sig_tvs
 803   = do  { zonked_tvs <- mapM zonkSigTyVar sig_tvs
 804         ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
 805         ; return zonked_tvs }
 806   where
 807     check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
 808         -- The TyVarEnv maps each zonked type variable back to its
 809         -- corresponding user-written signature type variable
 810     check_dup acc (sig_tv, zonked_tv)
 811         = case lookupVarEnv acc zonked_tv of
 812                 Just sig_tv' -> bomb_out sig_tv sig_tv'
 813
 814                 Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
 815
 816     bomb_out sig_tv1 sig_tv2
 817        = do { env0 <- tcInitTidyEnv
 818             ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1
 819                   (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
 820                   msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1)
 821                          <+> ptext SLIT("is unified with another quantified type variable")
 822                          <+> quotes (ppr tidy_tv2)
 823             ; failWithTcM (env2, msg) }
 824        where
 825 \end{code}
 826
 827
 828 @getTyVarsToGen@ decides what type variables to generalise over.
 829
 830 For a "restricted group" -- see the monomorphism restriction
 831 for a definition -- we bind no dictionaries, and
 832 remove from tyvars_to_gen any constrained type variables
 833
 834 *Don't* simplify dicts at this point, because we aren't going
 835 to generalise over these dicts.  By the time we do simplify them
 836 we may well know more.  For example (this actually came up)
 837         f :: Array Int Int
 838         f x = array ... xs where xs = [1,2,3,4,5]
 839 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
 840 stuff.  If we simplify only at the f-binding (not the xs-binding)
 841 we'll know that the literals are all Ints, and we can just produce
 842 Int literals!
 843
 844 Find all the type variables involved in overloading, the
 845 "constrained_tyvars".  These are the ones we *aren't* going to
 846 generalise.  We must be careful about doing this:
 847
 848  (a) If we fail to generalise a tyvar which is not actually
 849         constrained, then it will never, ever get bound, and lands
 850         up printed out in interface files!  Notorious example:
 851                 instance Eq a => Eq (Foo a b) where ..
 852         Here, b is not constrained, even though it looks as if it is.
 853         Another, more common, example is when there's a Method inst in
 854         the LIE, whose type might very well involve non-overloaded
 855         type variables.
 856   [NOTE: Jan 2001: I don't understand the problem here so I'm doing
 857         the simple thing instead]
 858
 859  (b) On the other hand, we mustn't generalise tyvars which are constrained,
 860         because we are going to pass on out the unmodified LIE, with those
 861         tyvars in it.  They won't be in scope if we've generalised them.
 862
 863 So we are careful, and do a complete simplification just to find the
 864 constrained tyvars. We don't use any of the results, except to
 865 find which tyvars are constrained.
 866
 867 Note [Polymorphic recursion]
 868 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 869 The game plan for polymorphic recursion in the code above is
 870
 871         * Bind any variable for which we have a type signature
 872           to an Id with a polymorphic type.  Then when type-checking
 873           the RHSs we'll make a full polymorphic call.
 874
 875 This fine, but if you aren't a bit careful you end up with a horrendous
 876 amount of partial application and (worse) a huge space leak. For example:
 877
 878         f :: Eq a => [a] -> [a]
 879         f xs = ...f...
 880
 881 If we don't take care, after typechecking we get
 882
 883         f = /\a -> \d::Eq a -> let f' = f a d
 884                                in
 885                                \ys:[a] -> ...f'...
 886
 887 Notice the the stupid construction of (f a d), which is of course
 888 identical to the function we're executing.  In this case, the
 889 polymorphic recursion isn't being used (but that's a very common case).
 890 This can lead to a massive space leak, from the following top-level defn
 891 (post-typechecking)
 892
 893         ff :: [Int] -> [Int]
 894         ff = f Int dEqInt
 895
 896 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
 897 f' is another thunk which evaluates to the same thing... and you end
 898 up with a chain of identical values all hung onto by the CAF ff.
 899
 900         ff = f Int dEqInt
 901
 902            = let f' = f Int dEqInt in \ys. ...f'...
 903
 904            = let f' = let f' = f Int dEqInt in \ys. ...f'...
 905                       in \ys. ...f'...
 906
 907 Etc.
 908
 909 NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
 910 which would make the space leak go away in this case
 911
 912 Solution: when typechecking the RHSs we always have in hand the
 913 *monomorphic* Ids for each binding.  So we just need to make sure that
 914 if (Method f a d) shows up in the constraints emerging from (...f...)
 915 we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
 916 to the "givens" when simplifying constraints.  That's what the "lies_avail"
 917 is doing.
 918
 919 Then we get
 920
 921         f = /\a -> \d::Eq a -> letrec
 922                                  fm = \ys:[a] -> ...fm...
 923                                in
 924                                fm
 925
 926
 927
 928 %************************************************************************
 929 %*                                                                      *
 930                 Signatures
 931 %*                                                                      *
 932 %************************************************************************
 933
 934 Type signatures are tricky.  See Note [Signature skolems] in TcType
 935
 936 @tcSigs@ checks the signatures for validity, and returns a list of
 937 {\em freshly-instantiated} signatures.  That is, the types are already
 938 split up, and have fresh type variables installed.  All non-type-signature
 939 "RenamedSigs" are ignored.
 940
 941 The @TcSigInfo@ contains @TcTypes@ because they are unified with
 942 the variable's type, and after that checked to see whether they've
 943 been instantiated.
 944
 945 \begin{code}
 946 type TcSigFun = Name -> Maybe [Name]    -- Maps a let-binder to the list of
 947                                         -- type variables brought into scope
 948                                         -- by its type signature.
 949                                         -- Nothing => no type signature
 950
 951 mkTcSigFun :: [LSig Name] -> TcSigFun
 952 -- Search for a particular type signature
 953 -- Precondition: the sigs are all type sigs
 954 -- Precondition: no duplicates
 955 mkTcSigFun sigs = lookupNameEnv env
 956   where
 957     env = mkNameEnv [(name, hsExplicitTvs lhs_ty)
 958                     | L span (TypeSig (L _ name) lhs_ty) <- sigs]
 959         -- The scoped names are the ones explicitly mentioned
 960         -- in the HsForAll.  (There may be more in sigma_ty, because
 961         -- of nested type synonyms.  See Note [Scoped] with TcSigInfo.)
 962         -- See Note [Only scoped tyvars are in the TyVarEnv]
 963
 964 ---------------
 965 data TcSigInfo
 966   = TcSigInfo {
 967         sig_id     :: TcId,             --  *Polymorphic* binder for this value...
 968
 969         sig_scoped :: [Name],           -- Names for any scoped type variables
 970                                         -- Invariant: correspond 1-1 with an initial
 971                                         -- segment of sig_tvs (see Note [Scoped])
 972
 973         sig_tvs    :: [TcTyVar],        -- Instantiated type variables
 974                                         -- See Note [Instantiate sig]
 975
 976         sig_theta  :: TcThetaType,      -- Instantiated theta
 977         sig_tau    :: TcTauType,        -- Instantiated tau
 978         sig_loc    :: InstLoc           -- The location of the signature
 979     }
 980
 981
 982 --      Note [Only scoped tyvars are in the TyVarEnv]
 983 -- We are careful to keep only the *lexically scoped* type variables in
 984 -- the type environment.  Why?  After all, the renamer has ensured
 985 -- that only legal occurrences occur, so we could put all type variables
 986 -- into the type env.
 987 --
 988 -- But we want to check that two distinct lexically scoped type variables
 989 -- do not map to the same internal type variable.  So we need to know which
 990 -- the lexically-scoped ones are... and at the moment we do that by putting
 991 -- only the lexically scoped ones into the environment.
 992
 993
 994 --      Note [Scoped]
 995 -- There may be more instantiated type variables than scoped
 996 -- ones.  For example:
 997 --      type T a = forall b. b -> (a,b)
 998 --      f :: forall c. T c
 999 -- Here, the signature for f will have one scoped type variable, c,
1000 -- but two instantiated type variables, c' and b'.
1001 --
1002 -- We assume that the scoped ones are at the *front* of sig_tvs,
1003 -- and remember the names from the original HsForAllTy in sig_scoped
1004
1005 --      Note [Instantiate sig]
1006 -- It's vital to instantiate a type signature with fresh variables.
1007 -- For example:
1008 --      type S = forall a. a->a
1009 --      f,g :: S
1010 --      f = ...
1011 --      g = ...
1012 -- Here, we must use distinct type variables when checking f,g's right hand sides.
1013 -- (Instantiation is only necessary because of type synonyms.  Otherwise,
1014 -- it's all cool; each signature has distinct type variables from the renamer.)
1015
1016 instance Outputable TcSigInfo where
1017     ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
1018         = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
1019 \end{code}
1020
1021 \begin{code}
1022 tcTySig :: LSig Name -> TcM TcId
1023 tcTySig (L span (TypeSig (L _ name) ty))
1024   = setSrcSpan span             $
1025     do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
1026         ; return (mkLocalId name sigma_ty) }
1027
1028 -------------------
1029 tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo)
1030 -- Instantiate with *meta* type variables;
1031 -- this signature is part of a multi-signature group
1032 tcInstSig_maybe sig_fn name
1033   = case sig_fn name of
1034         Nothing  -> return Nothing
1035         Just tvs -> do  { tc_sig <- tcInstSig False name tvs
1036                         ; return (Just tc_sig) }
1037
1038 tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo
1039 -- Instantiate the signature, with either skolems or meta-type variables
1040 -- depending on the use_skols boolean.  This variable is set True
1041 -- when we are typechecking a single function binding; and False for
1042 -- pattern bindings and a group of several function bindings.
1043 -- Reason: in the latter cases, the "skolems" can be unified together,
1044 --         so they aren't properly rigid in the type-refinement sense.
1045 -- NB: unless we are doing H98, each function with a sig will be done
1046 --     separately, even if it's mutually recursive, so use_skols will be True
1047 --
1048 -- We always instantiate with fresh uniques,
1049 -- although we keep the same print-name
1050 --
1051 --      type T = forall a. [a] -> [a]
1052 --      f :: T;
1053 --      f = g where { g :: T; g = <rhs> }
1054 --
1055 -- We must not use the same 'a' from the defn of T at both places!!
1056
1057 tcInstSig use_skols name scoped_names
1058   = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into
1059                                         -- scope when starting the binding group
1060         ; let skol_info = SigSkol (FunSigCtxt name)
1061               inst_tyvars | use_skols = tcInstSkolTyVars skol_info
1062                           | otherwise = tcInstSigTyVars  skol_info
1063         ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
1064         ; loc <- getInstLoc (SigOrigin skol_info)
1065         ; return (TcSigInfo { sig_id = poly_id,
1066                               sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
1067                               sig_scoped = final_scoped_names, sig_loc = loc }) }
1068                 -- Note that the scoped_names and the sig_tvs will have
1069                 -- different Names. That's quite ok; when we bring the
1070                 -- scoped_names into scope, we just bind them to the sig_tvs
1071   where
1072         -- We also only have scoped type variables when we are instantiating
1073         -- with true skolems
1074     final_scoped_names | use_skols = scoped_names
1075                        | otherwise = []
1076
1077 -------------------
1078 isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
1079 -- No generalisation at all
1080 isMonoGroup dflags binds
1081   = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
1082   where
1083     is_pat_bind (L _ (PatBind {})) = True
1084     is_pat_bind other              = False
1085
1086 -------------------
1087 isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool
1088 isRestrictedGroup dflags binds sig_fn
1089   = mono_restriction && not all_unrestricted
1090   where
1091     mono_restriction = dopt Opt_MonomorphismRestriction dflags
1092     all_unrestricted = all (unrestricted . unLoc) binds
1093     has_sig n = isJust (sig_fn n)
1094
1095     unrestricted (PatBind {})                                    = False
1096     unrestricted (VarBind { var_id = v })                        = has_sig v
1097     unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches
1098                                                                  || has_sig (unLoc v)
1099
1100     unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
1101         -- No args => like a pattern binding
1102     unrestricted_match other              = True
1103         -- Some args => a function binding
1104 \end{code}
1105
1106
1107 %************************************************************************
1108 %*                                                                      *
1109 \subsection[TcBinds-errors]{Error contexts and messages}
1110 %*                                                                      *
1111 %************************************************************************
1112
1113
1114 \begin{code}
1115 -- This one is called on LHS, when pat and grhss are both Name
1116 -- and on RHS, when pat is TcId and grhss is still Name
1117 patMonoBindsCtxt pat grhss
1118   = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
1119
1120 -----------------------------------------------
1121 sigContextsCtxt sig1 sig2
1122   = vcat [ptext SLIT("When matching the contexts of the signatures for"),
1123           nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
1124                         ppr id2 <+> dcolon <+> ppr (idType id2)]),
1125           ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
1126   where
1127     id1 = sig_id sig1
1128     id2 = sig_id sig2
1129
1130
1131 -----------------------------------------------
1132 unboxedTupleErr name ty
1133   = hang (ptext SLIT("Illegal binding of unboxed tuple"))
1134          4 (ppr name <+> dcolon <+> ppr ty)
1135
1136 -----------------------------------------------
1137 restrictedBindCtxtErr binder_names
1138   = hang (ptext SLIT("Illegal overloaded type signature(s)"))
1139        4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
1140                 ptext SLIT("that falls under the monomorphism restriction")])
1141
1142 genCtxt binder_names
1143   = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
1144 \end{code}