ghc/compiler/typecheck/TcBinds.lhs

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