X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=b52ef1ff22e5f6a0ccf9f00a295f9cb5669861b7;hb=0f800dc9f3dc695cd06d0fdd7799a52c37241752;hp=25c78338aa77dcddbc6d5db02be7b4be1220357d;hpb=f8d1d20eb4779a42e72b6a06c47d6e0f13075bf4;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 25c7833..cffcb9c 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -1,69 +1,72 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcBinds]{TcBinds} \begin{code} -#include "HsVersions.h" - -module TcBinds ( tcBindsAndThen, tcPragmaSigs, checkSigTyVars, tcBindWithSigs, TcSigInfo(..) ) where - -IMP_Ubiq() +module TcBinds ( tcLocalBinds, tcTopBinds, + tcHsBootSigs, tcMonoBinds, + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), + badBootDeclErr ) where -import HsSyn ( HsBinds(..), Sig(..), MonoBinds(..), - Match, HsType, InPat(..), OutPat(..), HsExpr(..), - SYN_IE(RecFlag), nonRecursive, - GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, Stmt, DoOrListComp, Fixity, - collectMonoBinders ) -import RnHsSyn ( SYN_IE(RenamedHsBinds), RenamedSig(..), - SYN_IE(RenamedMonoBinds) - ) -import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), - TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), - tcIdType - ) +#include "HsVersions.h" -import TcMonad -import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..), - newDicts, tyVarsOfInst, instToId - ) -import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds, - tcGetGlobalTyVars, tcExtendGlobalTyVars +import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} TcExpr ( tcMonoExpr ) + +import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) ) +import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), + HsLocalBinds(..), HsValBinds(..), HsIPBinds(..), + LSig, Match(..), IPBind(..), Prag(..), + HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, + isVanillaLSig, sigName, placeHolderNames, isPragLSig, + LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce, + collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind ) -import SpecEnv ( SpecEnv ) -IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) -import TcMatches ( tcMatchesFun ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) -import TcMonoType ( tcHsType ) -import TcPat ( tcPat ) +import TcHsSyn ( zonkId ) + +import TcRnMonad +import Inst ( newDictsAtLoc, newIPDict, instToId ) +import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, + pprBinders, tcLookupLocalId_maybe, tcLookupId, + tcGetGlobalTyVars ) +import TcUnify ( tcInfer, tcSubExp, unifyTheta, + bleatEscapedTvs, sigCtxt ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, + tcSimplifyRestricted, tcSimplifyIPs ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) +import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( SYN_IE(TcType), SYN_IE(TcThetaType), SYN_IE(TcTauType), - SYN_IE(TcTyVarSet), SYN_IE(TcTyVar), - newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars, - newTcTyVar, tcInstSigType, newTyVarTys - ) -import Unify ( unifyTauTy, unifyTauTyLists ) - -import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind ) -import Id ( GenId, idType, mkUserLocal, mkUserId ) -import IdInfo ( noIdInfo ) -import Maybes ( maybeToBool, assocMaybe, catMaybes ) -import Name ( getOccName, getSrcLoc, Name ) -import PragmaInfo ( PragmaInfo(..) ) -import Pretty -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes, eqSimpleTheta, - mkSigmaTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy, - splitRhoTy, mkForAllTy, splitForAllTy ) -import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet, - elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) -import Bag ( bagToList, foldrBag, isEmptyBag ) -import Util ( isIn, zipEqual, zipWithEqual, zipWith3Equal, hasNoDups, assoc, - assertPanic, panic, pprTrace ) -import PprType ( GenClass, GenType, GenTyVar ) -import Unique ( Unique ) -import SrcLoc ( SrcLoc ) - -import Outputable --( interppSP, interpp'SP ) +import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar, + tcInstSigTyVars, tcInstSkolTyVars, tcInstType, + zonkTcType, zonkTcTypes, zonkTcTyVars ) +import TcType ( TcType, TcTyVar, TcThetaType, + SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), + TcTauType, TcSigmaType, isUnboxedTupleType, + mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, + mkForAllTy, isUnLiftedType, tcGetTyVar, + mkTyVarTys, tidyOpenTyVar ) +import Kind ( argTypeKind ) +import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) +import TysWiredIn ( unitTy ) +import TysPrim ( alphaTyVar ) +import Id ( Id, mkLocalId, mkVanillaGlobal ) +import IdInfo ( vanillaIdInfo ) +import Var ( TyVar, idType, idName ) +import Name ( Name ) +import NameSet +import NameEnv +import VarSet +import SrcLoc ( Located(..), unLoc, getLoc ) +import Bag +import ErrUtils ( Message ) +import Digraph ( SCC(..), stronglyConnComp ) +import Maybes ( expectJust, isJust, isNothing, orElse ) +import Util ( singleton ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, + RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec ) +import Outputable \end{code} @@ -99,238 +102,736 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcBindsAndThen - :: (TcHsBinds s -> thing -> thing) -- Combinator - -> RenamedHsBinds - -> TcM s (thing, LIE s) - -> TcM s (thing, LIE s) - -tcBindsAndThen combiner EmptyBinds do_next - = do_next `thenTc` \ (thing, lie) -> - returnTc (combiner EmptyBinds thing, lie) - -tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next - = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next) - -tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next - = fixTc (\ ~(prag_info_fn, _) -> - -- This is the usual prag_info fix; the PragmaInfo field of an Id - -- is not inspected till ages later in the compiler, so there - -- should be no black-hole problems here. - - -- TYPECHECK THE SIGNATURES - mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs -> - - tcBindWithSigs binder_names bind - tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) -> - - -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv binder_names poly_ids $ - - -- Build bindings and IdInfos corresponding to user pragmas - tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) -> - - -- Now do whatever happens next, in the augmented envt - do_next `thenTc` \ (thing, thing_lie) -> - - -- Create specialisations of functions bound here - bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie) - poly_ids `thenTc` \ (lie2, inst_mbinds) -> - - -- All done - let - final_lie = lie2 `plusLIE` poly_lie - final_binds = MonoBind poly_binds [] is_rec `ThenBinds` - MonoBind inst_mbinds [] nonRecursive `ThenBinds` - prag_binds - in - returnTc (prag_info_fn, (combiner final_binds thing, final_lie)) - ) `thenTc` \ (_, result) -> - returnTc result +tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv) + -- Note: returning the TcLclEnv is more than we really + -- want. The bit we care about is the local bindings + -- and the free type variables thereof +tcTopBinds binds + = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv + ; return (foldr (unionBags . snd) emptyBag prs, env) } + -- The top level bindings are flattened into a giant + -- implicitly-mutually-recursive LHsBinds + +tcHsBootSigs :: HsValBinds Name -> TcM [Id] +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this +tcHsBootSigs (ValBindsOut binds sigs) + = do { checkTc (null binds) badBootDeclErr + ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } where - binder_names = map fst (bagToList (collectMonoBinders bind)) - ty_sigs = [sig | sig@(Sig name _ _) <- sigs] + tc_boot_sig (TypeSig (L _ name) ty) + = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) } + -- Notice that we make GlobalIds, not LocalIds +tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) + +badBootDeclErr :: Message +badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") + +------------------------ +tcLocalBinds :: HsLocalBinds Name -> TcM thing + -> TcM (HsLocalBinds TcId, thing) + +tcLocalBinds EmptyLocalBinds thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } + +tcLocalBinds (HsValBinds binds) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside + ; return (HsValBinds binds', thing) } + +tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside + = do { (thing, lie) <- getLIE thing_inside + ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + ; dict_binds <- tcSimplifyIPs avail_ips lie + ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) } + where + -- I wonder if we should do these one at at time + -- Consider ?x = 4 + -- ?y = ?x + 1 + tc_ip_bind (IPBind ip expr) + = newFlexiTyVarTy argTypeKind `thenM` \ ty -> + newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> + tcMonoExpr expr ty `thenM` \ expr' -> + returnM (ip_inst, (IPBind ip' expr')) + +------------------------ +tcValBinds :: TopLevelFlag + -> HsValBinds Name -> TcM thing + -> TcM (HsValBinds TcId, thing) + +tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside + = pprPanic "tcValBinds" (ppr binds) + +tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside + = do { -- Typecheck the signature + ; let { prag_fn = mkPragFun sigs + ; ty_sigs = filter isVanillaLSig sigs + ; sig_fn = mkSigFun ty_sigs } + + ; poly_ids <- mapM tcTySig ty_sigs + + -- Extend the envt right away with all + -- the Ids declared with type signatures + ; (binds', thing) <- tcExtendIdEnv poly_ids $ + tc_val_binds top_lvl sig_fn prag_fn + binds thing_inside + + ; return (ValBindsOut binds' sigs, thing) } + +------------------------ +tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun + -> [(RecFlag, LHsBinds Name)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time + +tc_val_binds top_lvl sig_fn prag_fn [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside + = do { (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn group $ + tc_val_binds top_lvl sig_fn prag_fn groups thing_inside + ; return (group' ++ groups', thing) } + +------------------------ +tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun + -> (RecFlag, LHsBinds Name) -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside + = -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive + sig_fn prag_fn binds thing_inside + ; return ([(NonRecursive, b) | b <- binds], thing) } + +tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside + = -- A recursive strongly-connected component + -- To maximise polymorphism (with -fglasgow-exts), we do a new + -- strongly-connected-component analysis, this time omitting + -- any references to variables with type signatures. + -- + -- Then we bring into scope all the variables with type signatures + do { traceTc (text "tc_group rec" <+> pprLHsBinds binds) + ; gla_exts <- doptM Opt_GlasgowExts + ; (binds,thing) <- if gla_exts + then go new_sccs + else tc_binds Recursive binds thing_inside + ; return ([(Recursive, unionManyBags binds)], thing) } + -- Rec them all together + where + new_sccs :: [SCC (LHsBind Name)] + new_sccs = stronglyConnComp (mkEdges sig_fn binds) -\end{code} +-- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing) + go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs) + ; return (binds1 ++ binds2, thing) } + go [] = do { thing <- thing_inside; return ([], thing) } + + go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind) + go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds) -An aside. The original version of @tcBindsAndThen@ which lacks a -combiner function, appears below. Though it is perfectly well -behaved, it cannot be typed by Haskell, because the recursive call is -at a different type to the definition itself. There aren't too many -examples of this, which is why I thought it worth preserving! [SLPJ] + tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds -\begin{pseudocode} -tcBindsAndThen - :: RenamedHsBinds - -> TcM s (thing, LIE s, thing_ty)) - -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty) +------------------------ +mkEdges :: TcSigFun -> LHsBinds Name + -> [(LHsBind Name, BKey, [BKey])] -tcBindsAndThen EmptyBinds do_next - = do_next `thenTc` \ (thing, lie, thing_ty) -> - returnTc ((EmptyBinds, thing), lie, thing_ty) +type BKey = Int -- Just number off the bindings -tcBindsAndThen (ThenBinds binds1 binds2) do_next - = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next) - `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) -> +mkEdges sig_fn binds + = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)), + Just key <- [lookupNameEnv key_map n], no_sig n ]) + | (bind, key) <- keyd_binds + ] + where + no_sig :: Name -> Bool + no_sig n = isNothing (sig_fn n) + + keyd_binds = bagToList binds `zip` [0::BKey ..] + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- bindersOfHsBind bind ] + +bindersOfHsBind :: HsBind Name -> [Name] +bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat +bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] + +------------------------ +tcPolyBinds :: TopLevelFlag + -> RecFlag -- Whether the group is really recursive + -> RecFlag -- Whether it's recursive for typechecking purposes + -> TcSigFun -> TcPragFun + -> LHsBinds Name + -> TcM thing + -> TcM ([LHsBinds TcId], thing) + +-- Typechecks a single bunch of bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Deals with the bindInstsOfLocalFuns thing too +-- +-- Returns a list because the input may be a single non-recursive binding, +-- in which case the dependency order of the resulting bindings is +-- important. + +tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside + = -- NB: polymorphic recursion means that a function + -- may use an instance of itself, we must look at the LIE arising + -- from the function's own right hand side. Hence the getLIE + -- encloses the tc_poly_binds. + do { traceTc (text "tcPolyBinds" <+> ppr scc) + ; ((binds1, poly_ids, thing), lie) <- getLIE $ + do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc + sig_fn prag_fn scc + ; thing <- tcExtendIdEnv poly_ids thing_inside + ; return (binds1, poly_ids, thing) } + + ; if isTopLevel top_lvl + then -- For the top level don't bother will all this + -- bindInstsOfLocalFuns stuff. All the top level + -- things are rec'd together anyway, so it's fine to + -- leave them to the tcSimplifyTop, + -- and quite a bit faster too + do { extendLIEs lie; return (binds1, thing) } + + else do -- Nested case + { lie_binds <- bindInstsOfLocalFuns lie poly_ids + ; return (binds1 ++ [lie_binds], thing) }} + +------------------------ +tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds + -> RecFlag -> RecFlag + -> TcSigFun -> TcPragFun + -> LHsBinds Name + -> TcM ([LHsBinds TcId], [TcId]) +-- Typechecks the bindings themselves +-- Knows nothing about the scope of the bindings + +tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds + = let + binder_names = collectHsBindBinders binds + bind_list = bagToList binds + + loc = getLoc (head bind_list) + -- TODO: location a bit awkward, but the mbinds have been + -- dependency analysed and may no longer be adjacent + in + -- SET UP THE MAIN RECOVERY; take advantage of any type sigs + setSrcSpan loc $ + recoverM (recoveryCode binder_names) $ do + + { traceTc (ptext SLIT("------------------------------------------------")) + ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) + + -- TYPECHECK THE BINDINGS + ; ((binds', mono_bind_infos), lie_req) + <- getLIE (tcMonoBinds bind_list sig_fn rec_tc) + + -- CHECK FOR UNLIFTED BINDINGS + -- These must be non-recursive etc, and are not generalised + -- They desugar to a case expression in the end + ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos) + ; is_strict <- checkStrictBinds top_lvl rec_group binds' + zonked_mono_tys mono_bind_infos + ; if is_strict then + do { extendLIEs lie_req + ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys + mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, []) + mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, []) + -- ToDo: prags for unlifted bindings + + ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked + + else do -- The normal lifted case: GENERALISE + { is_unres <- isUnRestrictedGroup bind_list sig_fn + ; (tyvars_to_gen, dict_binds, dict_ids) + <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ + generalise top_lvl is_unres mono_bind_infos lie_req + + -- FINALISE THE QUANTIFIED TYPE VARIABLES + -- The quantified type variables often include meta type variables + -- we want to freeze them into ordinary type variables, and + -- default their kind (e.g. from OpenTypeKind to TypeKind) + ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen + + -- BUILD THE POLYMORPHIC RESULT IDs + ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids)) + mono_bind_infos + + -- ZONK THE poly_ids, because they are used to extend the type + -- environment; see the invariant on TcEnv.tcExtendIdEnv + ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] + ; zonked_poly_ids <- mappM zonkId poly_ids + + ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids)) + + ; let abs_bind = L loc $ AbsBinds tyvars_to_gen' + dict_ids exports + (dict_binds `unionBags` binds') + + ; return ([unitBag abs_bind], zonked_poly_ids) + } } + + +-------------- +mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [Prag]) +mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) + = case mb_sig of + Nothing -> do { prags <- tcPrags poly_id (prag_fn poly_name) + ; return (inferred_tvs, poly_id, mono_id, prags) } + where + poly_id = mkLocalId poly_name poly_ty + poly_ty = mkForAllTys inferred_tvs + $ mkFunTys dict_tys + $ idType mono_id + + Just sig -> do { let poly_id = sig_id sig + ; prags <- tcPrags poly_id (prag_fn poly_name) + ; sig_tys <- zonkTcTyVars (sig_tvs sig) + ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys + ; return (sig_tvs', poly_id, mono_id, prags) } + -- We zonk the sig_tvs here so that the export triple + -- always has zonked type variables; + -- a convenient invariant + + +------------------------ +type TcPragFun = Name -> [LSig Name] + +mkPragFun :: [LSig Name] -> TcPragFun +mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] + where + prs = [(expectJust "mkPragFun" (sigName sig), sig) + | sig <- sigs, isPragLSig sig] + env = foldl add emptyNameEnv prs + add env (n,p) = extendNameEnv_Acc (:) singleton env n p - returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty) +tcPrags :: Id -> [LSig Name] -> TcM [Prag] +tcPrags poly_id prags = mapM tc_prag prags + where + tc_prag (L loc prag) = setSrcSpan loc $ + addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag + +pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) + +tcPrag :: TcId -> Sig Name -> TcM Prag +tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl +tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec +tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl) + + +tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag +tcSpecPrag poly_id hs_ty inl + = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty + ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) + ; extendLIEs lie + ; let const_dicts = map instToId lie + ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) } + +-------------- +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode binder_names + = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) + ; poly_ids <- mapM mk_dummy binder_names + ; return ([], poly_ids) } + where + mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name + ; case mb_id of + Just id -> return id -- Had signature, was in envt + Nothing -> return (mkLocalId name forall_a_a) } -- No signature + +forall_a_a :: TcType +forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) + + +-- Check that non-overloaded unlifted bindings are +-- a) non-recursive, +-- b) not top level, +-- c) not a multiple-binding group (more or less implied by (a)) + +checkStrictBinds :: TopLevelFlag -> RecFlag + -> LHsBinds TcId -> [TcType] -> [MonoBindInfo] + -> TcM Bool +checkStrictBinds top_lvl rec_group mbind mono_tys infos + | unlifted || bang_pat + = do { checkTc (isNotTopLevel top_lvl) + (strictBindErr "Top-level" unlifted mbind) + ; checkTc (isNonRec rec_group) + (strictBindErr "Recursive" unlifted mbind) + ; checkTc (isSingletonBag mbind) + (strictBindErr "Multiple" unlifted mbind) + ; mapM_ check_sig infos + ; return True } + | otherwise + = return False + where + unlifted = any isUnLiftedType mono_tys + bang_pat = anyBag (isBangHsBind . unLoc) mbind + check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig)) + (badStrictSig unlifted sig) + check_sig other = return () + +strictBindErr flavour unlifted mbind + = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) 4 (ppr mbind) + where + msg | unlifted = ptext SLIT("bindings for unlifted types") + | otherwise = ptext SLIT("bang-pattern bindings") -tcBindsAndThen (MonoBind bind sigs is_rec) do_next - = tcBindAndThen bind sigs do_next -\end{pseudocode} +badStrictSig unlifted sig + = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg) + 4 (ppr sig) + where + msg | unlifted = ptext SLIT("an unlifted binding") + | otherwise = ptext SLIT("a bang-pattern binding") +\end{code} %************************************************************************ %* * -\subsection{tcBindWithSigs} +\subsection{tcMonoBind} %* * %************************************************************************ -@tcBindWithSigs@ deals with a single binding group. It does generalisation, -so all the clever stuff is in here. +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. +The signatures have been dealt with already. -* binder_names and mbind must define the same set of Names +\begin{code} +tcMonoBinds :: [LHsBind Name] + -> TcSigFun + -> RecFlag -- Whether the binding is recursive for typechecking purposes + -- i.e. the binders are mentioned in their RHSs, and + -- we are not resuced by a type signature + -> TcM (LHsBinds TcId, [MonoBindInfo]) + +tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + sig_fn -- Single function binding, + NonRecursive -- binder isn't mentioned in RHS, + | Nothing <- sig_fn name -- ...with no type signature + = -- In this very special case we infer the type of the + -- right hand side first (it may have a higher-rank type) + -- and *then* make the monomorphic Id for the LHS + -- e.g. f = \(x::forall a. a->a) -> + -- We want to infer a higher-rank type for f + setSrcSpan b_loc $ + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + + -- Check for an unboxed tuple type + -- f = (# True, False #) + -- Zonk first just in case it's hidden inside a meta type variable + -- (This shows up as a (more obscure) kind error + -- in the 'otherwise' case of tcMonoBinds.) + ; zonked_rhs_ty <- zonkTcType rhs_ty + ; checkTc (not (isUnboxedTupleType zonked_rhs_ty)) + (unboxedTupleErr name zonked_rhs_ty) + + ; mono_name <- newLocalName name + ; let mono_id = mkLocalId mono_name zonked_rhs_ty + ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, + fun_matches = matches', bind_fvs = fvs, + fun_co_fn = co_fn })), + [(name, Nothing, mono_id)]) } + +tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, + fun_matches = matches, bind_fvs = fvs })] + sig_fn -- Single function binding + non_rec + | Just sig <- sig_fn name -- ...with a type signature + = -- When we have a single function binding, with a type signature + -- we can (a) use genuine, rigid skolem constants for the type variables + -- (b) bring (rigid) scoped type variables into scope + setSrcSpan b_loc $ + do { tc_sig <- tcInstSig True sig + ; mono_name <- newLocalName name + ; let mono_ty = sig_tau tc_sig + mono_id = mkLocalId mono_name mono_ty + rhs_tvs = [ (name, mkTyVarTy tv) + | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] + + ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ + tcMatchesFun mono_name matches mono_ty + + ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, + fun_infix = inf, fun_matches = matches', + bind_fvs = placeHolderNames, fun_co_fn = co_fn } + ; return (unitBag (L b_loc fun_bind'), + [(name, Just tc_sig, mono_id)]) } + +tcMonoBinds binds sig_fn non_rec + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds + + -- Bring the monomorphic Ids, into scope for the RHSs + ; let mono_info = getMonoBindInfo tc_binds + rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info] + -- A monomorphic binding for each term variable that lacks + -- a type sig. (Ones with a sig are already in scope.) + + ; binds' <- tcExtendIdEnv2 rhs_id_env $ + traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env]) `thenM_` + mapM (wrapLocM tcRhs) tc_binds + ; return (listToBag binds', mono_info) } + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType + +type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) + -- Type signature (if any), and + -- the monomorphic bound things + +bndrNames :: [MonoBindInfo] -> [Name] +bndrNames mbi = [n | (n,_,_) <- mbi] + +getMonoType :: MonoBindInfo -> TcTauType +getMonoType (_,_,mono_id) = idType mono_id + +tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind +tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) + = do { mb_sig <- tcInstSig_maybe (sig_fn name) + ; mono_name <- newLocalName name + ; mono_ty <- mk_mono_ty mb_sig + ; let mono_id = mkLocalId mono_name mono_ty + ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) } + where + mk_mono_ty (Just sig) = return (sig_tau sig) + mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind -* The Names in tc_ty_sigs must be a subset of binder_names +tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) + = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names -* The Ids in tc_ty_sigs don't necessarily have to have the same name - as the Name in the tc_ty_sig + ; let nm_sig_prs = names `zip` mb_sigs + tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs] + sig_tau_fn = lookupNameEnv tau_sig_env -\begin{code} -tcBindWithSigs - :: [Name] - -> RenamedMonoBinds - -> [TcSigInfo s] - -> RecFlag - -> (Name -> PragmaInfo) - -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s]) - -tcBindWithSigs binder_names mbind tc_ty_sigs is_rec prag_info_fn - = recoverTc ( - -- If typechecking the binds fails, then return with each - -- signature-less binder given type (forall a.a), to minimise subsequent - -- error messages - newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ alpha_tv -> - let - forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - poly_ids = map mk_dummy binder_names - mk_dummy name = case maybeSig tc_ty_sigs name of - Just (TySigInfo _ poly_id _ _ _ _) -> poly_id -- Signature - Nothing -> mkUserId name forall_a_a NoPragmaInfo -- No signature - in - returnTc (EmptyMonoBinds, emptyLIE, poly_ids) - ) $ - - -- Create a new identifier for each binder, with each being given - -- a fresh unique, and a type-variable type. - tcGetUniques no_of_binders `thenNF_Tc` \ uniqs -> - mapNF_Tc mk_mono_id_ty binder_names `thenNF_Tc` \ mono_id_tys -> - let - mono_id_tyvars = tyVarsOfTypes mono_id_tys - mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs mono_id_tys - mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name) - in + tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ -> + mapM lookup_info nm_sig_prs + -- The unitTy is a bit bogus; it's the "result type" for lookup_info. - -- TYPECHECK THE BINDINGS - tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) -> + -- After typechecking the pattern, look up the binder + -- names, which the pattern has brought into scope. + lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo + lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name + ; return (name, mb_sig, mono_id) } - -- CHECK THAT THE SIGNATURES MATCH - -- (must do this before getTyVarsToGen) - checkSigMatch tc_ty_sigs `thenTc` \ sig_theta -> - - -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen - -- The tyvars_not_to_gen are free in the environment, and hence - -- candidates for generalisation, but sometimes the monomorphism - -- restriction means we can't generalise them nevertheless - getTyVarsToGen is_unrestricted mono_id_tyvars lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) -> - - -- DEAL WITH TYPE VARIABLE KINDS - mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ tyvars_to_gen_list -> - -- It's important that the final list (tyvars_to_gen_list) is fully - -- zonked, *including boxity*, because they'll be included in the forall types of - -- the polymorphic Ids, and instances of these Ids will be generated from them. - -- - -- This step can do unification => keep other zonking after this - - -- SIMPLIFY THE LIE - tcExtendGlobalTyVars tyvars_not_to_gen ( - if null tc_ty_sigs then - -- No signatures, so just simplify the lie - tcSimplify tyvars_to_gen lie `thenTc` \ (lie_free, dict_binds, lie_bound) -> - returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) - - else - zonk_theta sig_theta `thenNF_Tc` \ sig_theta' -> - newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) -> - -- It's important that sig_theta is zonked, because - -- dict_id is later used to form the type of the polymorphic thing, - -- and forall-types must be zonked so far as their bound variables - -- are concerned - - -- Check that the needed dicts can be expressed in - -- terms of the signature ones - tcAddErrCtxt (sigsCtxt tysig_names) $ - tcSimplifyAndCheck tyvars_to_gen dicts_sig lie `thenTc` \ (lie_free, dict_binds) -> - returnTc (lie_free, dict_binds, dict_ids) - - ) `thenTc` \ (lie_free, dict_binds, dicts_bound) -> - - ASSERT( not (any (isUnboxedTypeKind . tyVarKind) tyvars_to_gen_list) ) - -- The instCantBeGeneralised stuff in tcSimplify should have - -- already raised an error if we're trying to generalise an unboxed tyvar - -- (NB: unboxed tyvars are always introduced along with a class constraint) - -- and it's better done there because we have more precise origin information. - -- That's why we just use an ASSERT here. - - -- BUILD THE POLYMORPHIC RESULT IDs - mapNF_Tc zonkTcType mono_id_tys `thenNF_Tc` \ zonked_mono_id_types -> - let - exports = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types - dict_tys = map tcIdType dicts_bound - - mk_export binder_name mono_id zonked_mono_id_ty - | maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id) - | otherwise = (tyvars_to_gen_list, TcId poly_id, TcId mono_id) - where - maybe_sig = maybeSig tc_ty_sigs binder_name - Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig - poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name) - poly_ty = mkForAllTys tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty - -- It's important to build a fully-zonked poly_ty, because - -- we'll slurp out its free type variables when extending the - -- local environment (tcExtendLocalValEnv); if it's not zonked - -- it appears to have free tyvars that aren't actually free at all. - in + ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ + tcInfer tc_pat - -- BUILD RESULTS - returnTc ( - AbsBinds tyvars_to_gen_list - dicts_bound - exports - (dict_binds `AndMonoBinds` mbind'), - lie_free, - [poly_id | (_, TcId poly_id, _) <- exports] - ) + ; return (TcPatBind infos pat' grhss pat_ty) } where - no_of_binders = length binder_names + names = collectPatBinders pat - mk_mono_id_ty binder_name = case maybeSig tc_ty_sigs binder_name of - Just (TySigInfo name _ _ _ tau_ty _) -> returnNF_Tc tau_ty -- There's a signature - otherwise -> newTyVarTy kind -- No signature - tysig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs] - is_unrestricted = isUnRestrictedGroup tysig_names mbind +tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible - kind | is_rec = mkBoxedTypeKind -- Recursive, so no unboxed types - | otherwise = mkTypeKind -- Non-recursive, so we permit unboxed types +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches + (idType mono_id) + ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', + bind_fvs = placeHolderNames, fun_co_fn = co_fn }) } -zonk_theta theta = mapNF_Tc zonk theta - where - zonk (c,t) = zonkTcType t `thenNF_Tc` \ t' -> - returnNF_Tc (c,t') +tcRhs bind@(TcPatBind _ pat' grhss pat_ty) + = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcGRHSsPat grhss pat_ty + ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, + bind_fvs = placeHolderNames }) } + + +--------------------- +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldr (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest +\end{code} + + +%************************************************************************ +%* * + Generalisation +%* * +%************************************************************************ + +\begin{code} +generalise :: TopLevelFlag -> Bool + -> [MonoBindInfo] -> [Inst] + -> TcM ([TcTyVar], TcDictBinds, [TcId]) +generalise top_lvl is_unrestricted mono_infos lie_req + | not is_unrestricted -- RESTRICTED CASE + = -- Check signature contexts are empty + do { checkTc (all is_mono_sig sigs) + (restrictedBindCtxtErr bndrs) + + -- Now simplify with exactly that set of tyvars + -- We have to squash those Methods + ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs + tau_tvs lie_req + + -- Check that signature type variables are OK + ; final_qtvs <- checkSigsTyVars qtvs sigs + + ; return (final_qtvs, binds, []) } + + | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS + = tcSimplifyInfer doc tau_tvs lie_req + + | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty + ; let -- The "sig_avails" is the stuff available. We get that from + -- the context of the type signature, BUT ALSO the lie_avail + -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) + local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] + sig_avails = sig_lie ++ local_meths + + -- Check that the needed dicts can be + -- expressed in terms of the signature ones + ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req + + -- Check that signature type variables are OK + ; final_qtvs <- checkSigsTyVars forall_tvs sigs + + ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } + where + bndrs = bndrNames mono_infos + sigs = [sig | (_, Just sig, _) <- mono_infos] + tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos + -- NB: exactTyVarsOfType; see Note [Silly type synonym] + -- near defn of TcType.exactTyVarsOfType + is_mono_sig sig = null (sig_theta sig) + doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs + + mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, + sig_theta = theta, sig_loc = loc }) mono_id + = Method mono_id poly_id (mkTyVarTys tvs) theta loc \end{code} -@getImplicitStuffToGen@ decides what type variables generalise over. +unifyCtxts checks that all the signature contexts are the same +The type signatures on a mutually-recursive group of definitions +must all have the same context (or none). + +The trick here is that all the signatures should have the same +context, and we want to share type variables for that context, so that +all the right hand sides agree a common vocabulary for their type +constraints + +We unify them because, with polymorphic recursion, their types +might not otherwise be related. This is a rather subtle issue. + +\begin{code} +unifyCtxts :: [TcSigInfo] -> TcM [Inst] +unifyCtxts (sig1 : sigs) -- Argument is always non-empty + = do { mapM unify_ctxt sigs + ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) } + where + theta1 = sig_theta sig1 + unify_ctxt :: TcSigInfo -> TcM () + unify_ctxt sig@(TcSigInfo { sig_theta = theta }) + = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + addErrCtxt (sigContextsCtxt sig1 sig) $ + unifyTheta theta1 theta + +checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] +checkSigsTyVars qtvs sigs + = do { gbl_tvs <- tcGetGlobalTyVars + ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs + + ; let -- Sigh. Make sure that all the tyvars in the type sigs + -- appear in the returned ty var list, which is what we are + -- going to generalise over. Reason: we occasionally get + -- silly types like + -- type T a = () -> () + -- f :: T a + -- f () = () + -- Here, 'a' won't appear in qtvs, so we have to add it + sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s + all_tvs = varSetElems (extendVarSetList sig_tvs qtvs) + ; returnM all_tvs } + where + check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs, + sig_theta = theta, sig_tau = tau}) + = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $ + addErrCtxtM (sigCtxt id tvs theta tau) $ + do { tvs' <- checkDistinctTyVars tvs + ; ifM (any (`elemVarSet` gbl_tvs) tvs') + (bleatEscapedTvs gbl_tvs tvs tvs') + ; return tvs' } + +checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] +-- (checkDistinctTyVars tvs) checks that the tvs from one type signature +-- are still all type variables, and all distinct from each other. +-- It returns a zonked set of type variables. +-- For example, if the type sig is +-- f :: forall a b. a -> b -> b +-- we want to check that 'a' and 'b' haven't +-- (a) been unified with a non-tyvar type +-- (b) been unified with each other (all distinct) + +checkDistinctTyVars sig_tvs + = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs + ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs) + ; return zonked_tvs } + where + check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar) + -- The TyVarEnv maps each zonked type variable back to its + -- corresponding user-written signature type variable + check_dup acc (sig_tv, zonked_tv) + = case lookupVarEnv acc zonked_tv of + Just sig_tv' -> bomb_out sig_tv sig_tv' + + Nothing -> return (extendVarEnv acc zonked_tv sig_tv) + + bomb_out sig_tv1 sig_tv2 + = do { env0 <- tcInitTidyEnv + ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1 + (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2 + msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) + <+> ptext SLIT("is unified with another quantified type variable") + <+> quotes (ppr tidy_tv2) + ; failWithTcM (env2, msg) } + where +\end{code} + + +@getTyVarsToGen@ decides what type variables to generalise over. For a "restricted group" -- see the monomorphism restriction for a definition -- we bind no dictionaries, and @@ -358,6 +859,8 @@ generalise. We must be careful about doing this: Another, more common, example is when there's a Method inst in the LIE, whose type might very well involve non-overloaded type variables. + [NOTE: Jan 2001: I don't understand the problem here so I'm doing + the simple thing instead] (b) On the other hand, we mustn't generalise tyvars which are constrained, because we are going to pass on out the unmodified LIE, with those @@ -367,430 +870,210 @@ So we are careful, and do a complete simplification just to find the constrained tyvars. We don't use any of the results, except to find which tyvars are constrained. -\begin{code} -getTyVarsToGen is_unrestricted mono_tyvars lie - = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars -> - zonkTcTyVars mono_tyvars `thenNF_Tc` \ mentioned_tyvars -> - let - tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars - in - if is_unrestricted - then - returnTc (emptyTyVarSet, tyvars_to_gen) - else - tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> - let - -- ASSERT: dicts_sig is already zonked! - constrained_tyvars = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts - reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars - in - returnTc (constrained_tyvars, reduced_tyvars_to_gen) -\end{code} +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. -\begin{code} -isUnRestrictedGroup :: [Name] -- Signatures given for these - -> RenamedMonoBinds - -> Bool - -is_elem v vs = isIn "isUnResMono" v vs - -isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs -isUnRestrictedGroup sigs (PatMonoBind other _ _) = False -isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs -isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True -isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && - isUnRestrictedGroup sigs mb2 -isUnRestrictedGroup sigs EmptyMonoBinds = True -\end{code} +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: -@defaultUncommittedTyVar@ checks for generalisation over unboxed -types, and defaults any TypeKind TyVars to BoxedTypeKind. + f :: Eq a => [a] -> [a] + f xs = ...f... -\begin{code} -defaultUncommittedTyVar tyvar - | isTypeKind (tyVarKind tyvar) - = newTcTyVar mkBoxedTypeKind `thenNF_Tc` \ boxed_tyvar -> - unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar) `thenTc_` - returnTc boxed_tyvar +If we don't take care, after typechecking we get - | otherwise - = returnTc tyvar -\end{code} + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) -%************************************************************************ -%* * -\subsection{tcMonoBind} -%* * -%************************************************************************ - -@tcMonoBinds@ deals with a single @MonoBind@. -The signatures have been dealt with already. - -\begin{code} -tcMonoBinds :: RenamedMonoBinds - -> [Name] -> [TcIdBndr s] - -> [TcSigInfo s] - -> TcM s (TcMonoBinds s, LIE s) - -tcMonoBinds mbind binder_names mono_ids tc_ty_sigs - = tcExtendLocalValEnv binder_names mono_ids ( - tc_mono_binds mbind - ) - where - sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs] - sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs] - - tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE) - - tc_mono_binds (AndMonoBinds mb1 mb2) - = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) -> - tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) -> - returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2) - - tc_mono_binds (FunMonoBind name inf matches locn) - = tcAddSrcLoc locn $ - tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id -> - - -- Before checking the RHS, extend the envt with - -- bindings for the *polymorphic* Ids from any type signatures - tcExtendLocalValEnv sig_names sig_ids $ - tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) -> - - returnTc (FunMonoBind (TcId id) inf matches' locn, lie) - - tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn) - = tcAddSrcLoc locn $ - tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) -> - tcExtendLocalValEnv sig_names sig_ids $ - tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) -> - tcAddErrCtxt (patMonoBindsCtxt bind) $ - unifyTauTy pat_ty grhss_ty `thenTc_` - returnTc (PatMonoBind pat2 grhss_and_binds2 locn, - plusLIE lie_pat lie) -\end{code} - -%************************************************************************ -%* * -\subsection{Signatures} -%* * -%************************************************************************ - -@tcSigs@ checks the signatures for validity, and returns a list of -{\em freshly-instantiated} signatures. That is, the types are already -split up, and have fresh type variables installed. All non-type-signature -"RenamedSigs" are ignored. + ff :: [Int] -> [Int] + ff = f Int dEqInt -The @TcSigInfo@ contains @TcTypes@ because they are unified with -the variable's type, and after that checked to see whether they've -been instantiated. - -\begin{code} -data TcSigInfo s - = TySigInfo Name - (TcIdBndr s) -- *Polymorphic* binder for this value... - [TcTyVar s] (TcThetaType s) (TcTauType s) - SrcLoc - - -maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s) - -- Search for a particular signature -maybeSig [] name = Nothing -maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name - | name == sig_name = Just sig - | otherwise = maybeSig sigs name -\end{code} - - -\begin{code} -tcTySig :: (Name -> PragmaInfo) - -> RenamedSig - -> TcM s (TcSigInfo s) - -tcTySig prag_info_fn (Sig v ty src_loc) - = tcAddSrcLoc src_loc $ - tcHsType ty `thenTc` \ sigma_ty -> - tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> - let - poly_id = mkUserId v sigma_ty' (prag_info_fn v) - (tyvars', theta', tau') = splitSigmaTy sigma_ty' - -- This splitSigmaTy tries hard to make sure that tau' is a type synonym - -- wherever possible, which can improve interface files. - in - returnTc (TySigInfo v poly_id tyvars' theta' tau' src_loc) -\end{code} +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. -@checkSigMatch@ does the next step in checking signature matching. -The tau-type part has already been unified. What we do here is to -check that this unification has not over-constrained the (polymorphic) -type variables of the original signature type. + ff = f Int dEqInt -The error message here is somewhat unsatisfactory, but it'll do for -now (ToDo). + = let f' = f Int dEqInt in \ys. ...f'... -\begin{code} -checkSigMatch [] - = returnTc (error "checkSigMatch") + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... -checkSigMatch tc_ty_sigs - = -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE - -- The type signatures on a mutually-recursive group of definitions - -- must all have the same context (or none). - -- - -- We unify them because, with polymorphic recursion, their types - -- might not otherwise be related. This is a rather subtle issue. - -- ToDo: amplify - tcAddErrCtxt (sigContextsCtxt tc_ty_sigs) ( - mapTc (unifyTauTyLists dict_tys1) dict_tys_s - ) `thenTc_` - - -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK - -- Doesn't affect substitution - mapTc check_one_sig tc_ty_sigs `thenTc_` - - returnTc theta1 - where - (theta1:thetas) = [theta | TySigInfo _ _ _ theta _ _ <- tc_ty_sigs] - (dict_tys1 : dict_tys_s) = map mk_dict_tys (theta1 : thetas) - mk_dict_tys theta = [mkDictTy c t | (c,t) <- theta] - - check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (sigCtxt id) $ - checkSigTyVars sig_tyvars sig_tau -\end{code} +Etc. +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case -@checkSigTyVars@ is used after the type in a type signature has been unified with -the actual type found. It then checks that the type variables of the type signature -are - (a) still all type variables - eg matching signature [a] against inferred type [(p,q)] - [then a will be unified to a non-type variable] +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. - (b) still all distinct - eg matching signature [(a,b)] against inferred type [(p,p)] - [then a and b will be unified together] +Then we get -BUT ACTUALLY THESE FIRST TWO ARE FORCED BY USING DontBind TYVARS + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm - (c) not mentioned in the environment - eg the signature for f in this: - - g x = ... where - f :: a->[a] - f y = [x,y] - - Here, f is forced to be monorphic by the free occurence of x. - -Before doing this, the substitution is applied to the signature type variable. - -\begin{code} -checkSigTyVars :: [TcTyVar s] -- The original signature type variables - -> TcType s -- signature type (for err msg) - -> TcM s () - -checkSigTyVars sig_tyvars sig_tau - = tcGetGlobalTyVars `thenNF_Tc` \ globals -> - let - mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars - in - -- TEMPORARY FIX - -- Until the final Bind-handling stuff is in, several type signatures in the same - -- bindings group can cause the signature type variable from the different - -- signatures to be unified. So we still need to zonk and check point (b). - -- Remove when activating the new binding code - mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys -> - checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys)) - (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> - failTc (badMatchErr sig_tau sig_tau') - ) `thenTc_` - - - -- Check point (c) - -- We want to report errors in terms of the original signature tyvars, - -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond - -- 1-1 with sig_tyvars, so we can just map back. - checkTc (null mono_tyvars) - (notAsPolyAsSigErr sig_tau mono_tyvars) -\end{code} %************************************************************************ %* * -\subsection{SPECIALIZE pragmas} + Signatures %* * %************************************************************************ +Type signatures are tricky. See Note [Signature skolems] in TcType -@tcPragmaSigs@ munches up the "signatures" that arise through *user* -pragmas. It is convenient for them to appear in the @[RenamedSig]@ -part of a binding because then the same machinery can be used for -moving them into place as is done for type signatures. - -\begin{code} -tcPragmaSigs :: [RenamedSig] -- The pragma signatures - -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo - TcHsBinds s, - LIE s) - -tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE ) - -{- -tcPragmaSigs sigs - = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) -> - let - name_to_info name = foldr ($) noIdInfo - [info_fn | (n,info_fn) <- names_w_id_infos, n==name] - in - returnTc (name_to_info, - foldr ThenBinds EmptyBinds binds, - foldr plusLIE emptyLIE lies) -\end{code} +@tcSigs@ checks the signatures for validity, and returns a list of +{\em freshly-instantiated} signatures. That is, the types are already +split up, and have fresh type variables installed. All non-type-signature +"RenamedSigs" are ignored. -Here are the easy cases for tcPragmaSigs +The @TcSigInfo@ contains @TcTypes@ because they are unified with +the variable's type, and after that checked to see whether they've +been instantiated. \begin{code} -tcPragmaSig (DeforestSig name loc) - = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE) -tcPragmaSig (InlineSig name loc) - = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE) -tcPragmaSig (MagicUnfoldingSig name string loc) - = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE) -\end{code} +type TcSigFun = Name -> Maybe (LSig Name) -The interesting case is for SPECIALISE pragmas. There are two forms. -Here's the first form: -\begin{verbatim} - f :: Ord a => [a] -> b -> b - {-# SPECIALIZE f :: [Int] -> b -> b #-} -\end{verbatim} - -For this we generate: -\begin{verbatim} - f* = /\ b -> let d1 = ... - in f Int b d1 -\end{verbatim} - -where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to -retain a right-hand-side that the simplifier will otherwise discard as -dead code... the simplifier has a flag that tells it not to discard -SpecPragmaId bindings. - -In this case the f* retains a call-instance of the overloaded -function, f, (including appropriate dictionaries) so that the -specialiser will subsequently discover that there's a call of @f@ at -Int, and will create a specialisation for @f@. After that, the -binding for @f*@ can be discarded. - -The second form is this: -\begin{verbatim} - f :: Ord a => [a] -> b -> b - {-# SPECIALIZE f :: [Int] -> b -> b = g #-} -\end{verbatim} - -Here @g@ is specified as a function that implements the specialised -version of @f@. Suppose that g has type (a->b->b); that is, g's type -is more general than that required. For this we generate -\begin{verbatim} - f@Int = /\b -> g Int b - f* = f@Int -\end{verbatim} - -Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits -f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves -to prevent @f@@Int@ from being discarded prematurely. After specialisation, -if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can -discard the f* binding. - -Actually, there is really only point in giving a SPECIALISE pragma on exported things, -and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is -a bit of overkill. +mkSigFun :: [LSig Name] -> TcSigFun +-- Search for a particular type signature +-- Precondition: the sigs are all type sigs +-- Precondition: no duplicates +mkSigFun sigs = lookupNameEnv env + where + env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs] + +--------------- +data TcSigInfo + = TcSigInfo { + sig_id :: TcId, -- *Polymorphic* binder for this value... + + sig_scoped :: [Name], -- Names for any scoped type variables + -- Invariant: correspond 1-1 with an initial + -- segment of sig_tvs (see Note [Scoped]) + + sig_tvs :: [TcTyVar], -- Instantiated type variables + -- See Note [Instantiate sig] + + sig_theta :: TcThetaType, -- Instantiated theta + sig_tau :: TcTauType, -- Instantiated tau + sig_loc :: InstLoc -- The location of the signature + } + +-- Note [Scoped] +-- There may be more instantiated type variables than scoped +-- ones. For example: +-- type T a = forall b. b -> (a,b) +-- f :: forall c. T c +-- Here, the signature for f will have one scoped type variable, c, +-- but two instantiated type variables, c' and b'. +-- +-- We assume that the scoped ones are at the *front* of sig_tvs, +-- and remember the names from the original HsForAllTy in sig_scoped + +-- Note [Instantiate sig] +-- It's vital to instantiate a type signature with fresh variable. +-- For example: +-- type S = forall a. a->a +-- f,g :: S +-- f = ... +-- g = ... +-- Here, we must use distinct type variables when checking f,g's right hand sides. +-- (Instantiation is only necessary because of type synonyms. Otherwise, +-- it's all cool; each signature has distinct type variables from the renamer.) + +instance Outputable TcSigInfo where + ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) + = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau +\end{code} \begin{code} -tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxt (valSpecSigCtxt name spec_ty) $ - - -- Get and instantiate its alleged specialised type - tcHsType poly_ty `thenTc` \ sig_sigma -> - tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty -> - let - (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty - origin = ValSpecOrigin name - in - - -- Check that the SPECIALIZE pragma had an empty context - checkTc (null sig_theta) - (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_` - - -- Get and instantiate the type of the id mentioned - tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id -> - tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty -> - let - (main_tyvars, main_rho) = splitForAllTy main_ty - (main_theta,main_tau) = splitRhoTy main_rho - main_arg_tys = mkTyVarTys main_tyvars - in - - -- Check that the specialised type is indeed an instance of - -- the type of the main function. - unifyTauTy sig_tau main_tau `thenTc_` - checkSigTyVars sig_tyvars sig_tau `thenTc_` - - -- Check that the type variables of the polymorphic function are - -- either left polymorphic, or instantiate to ground type. - -- Also check that the overloaded type variables are instantiated to - -- ground type; or equivalently that all dictionaries have ground type - mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' -> - zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' -> - tcAddErrCtxt (specGroundnessCtxt main_arg_tys') - (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_` - tcAddErrCtxt (specContextGroundnessCtxt main_theta') - (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_` - - -- Build the SpecPragmaId; it is the thing that makes sure we - -- don't prematurely dead-code-eliminate the binding we are really interested in. - newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id -> - - -- Build a suitable binding; depending on whether we were given - -- a value (Maybe Name) to be used as the specialisation. - case using of - Nothing -> -- No implementation function specified - - -- Make a Method inst for the occurrence of the overloaded function - newMethodWithGivenTy (OccurrenceOf name) - (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) -> - - let - pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs - pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id)) - in - returnTc (pseudo_bind, lie, \ info -> info) - - Just spec_name -> -- Use spec_name as the specialisation value ... - - -- Type check a simple occurrence of the specialised Id - tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) -> - - -- Check that it has the correct type, and doesn't constrain the - -- signature variables at all - unifyTauTy sig_tau spec_tau `thenTc_` - checkSigTyVars sig_tyvars sig_tau `thenTc_` - - -- Make a local SpecId to bind to applied spec_id - newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id -> - - let - spec_rhs = mkHsTyLam sig_tyvars spec_body - spec_binds = VarMonoBind local_spec_id spec_rhs - `AndMonoBinds` - VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id)) - spec_info = SpecInfo spec_tys (length main_theta) local_spec_id - in - returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie) --} +tcTySig :: LSig Name -> TcM TcId +tcTySig (L span (TypeSig (L _ name) ty)) + = setSrcSpan span $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } + +------------------- +tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo) +-- Instantiate with *meta* type variables; +-- this signature is part of a multi-signature group +tcInstSig_maybe Nothing = return Nothing +tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig + ; return (Just tc_sig) } + +tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo +-- Instantiate the signature, with either skolems or meta-type variables +-- depending on the use_skols boolean +-- +-- We always instantiate with freshs uniques, +-- although we keep the same print-name +-- +-- type T = forall a. [a] -> [a] +-- f :: T; +-- f = g where { g :: T; g = } +-- +-- We must not use the same 'a' from the defn of T at both places!! + +tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) + = setSrcSpan loc $ + do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into + -- scope when starting the binding group + ; let skol_info = SigSkol (FunSigCtxt name) + inst_tyvars | use_skols = tcInstSkolTyVars skol_info + | otherwise = tcInstSigTyVars skol_info + ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) + ; loc <- getInstLoc (SigOrigin skol_info) + ; return (TcSigInfo { sig_id = poly_id, + sig_tvs = tvs, sig_theta = theta, sig_tau = tau, + sig_scoped = scoped_names, sig_loc = loc }) } + -- Note that the scoped_names and the sig_tvs will have + -- different Names. That's quite ok; when we bring the + -- scoped_names into scope, we just bind them to the sig_tvs + where + -- The scoped names are the ones explicitly mentioned + -- in the HsForAll. (There may be more in sigma_ty, because + -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) + -- We also only have scoped type variables when we are instantiating + -- with true skolems + scoped_names = case (use_skols, hs_ty) of + (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs + other -> [] + +------------------- +isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool +isUnRestrictedGroup binds sig_fn + = do { mono_restriction <- doptM Opt_MonomorphismRestriction + ; return (not mono_restriction || all_unrestricted) } + where + all_unrestricted = all (unrestricted . unLoc) binds + has_sig n = isJust (sig_fn n) + + unrestricted (PatBind {}) = False + unrestricted (VarBind { var_id = v }) = has_sig v + unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches + || has_sig (unLoc v) + + unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False + -- No args => like a pattern binding + unrestricted_match other = True + -- Some args => a function binding \end{code} @@ -802,77 +1085,33 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) \begin{code} -patMonoBindsCtxt bind sty - = hang (ptext SLIT("In a pattern binding:")) 4 (ppr sty bind) +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt pat grhss + = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- -valSpecSigCtxt v ty sty - = hang (ptext SLIT("In a SPECIALIZE pragma for a value:")) - 4 (sep [(<>) (ppr sty v) (ptext SLIT(" ::")), - ppr sty ty]) - - +sigContextsCtxt sig1 sig2 + = vcat [ptext SLIT("When matching the contexts of the signatures for"), + nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), + ppr id2 <+> dcolon <+> ppr (idType id2)]), + ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] + where + id1 = sig_id sig1 + id2 = sig_id sig2 ------------------------------------------------ -notAsPolyAsSigErr sig_tau mono_tyvars sty - = hang (ptext SLIT("A type signature is more polymorphic than the inferred type")) - 4 (vcat [text "Some type variables in the inferred type can't be forall'd, namely:", - interpp'SP sty mono_tyvars, - ptext SLIT("Possible cause: the RHS mentions something subject to the monomorphism restriction") - ]) ----------------------------------------------- -badMatchErr sig_ty inferred_ty sty - = hang (ptext SLIT("Type signature doesn't match inferred type")) - 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sty sig_ty), - hang (ptext SLIT("Inferred :")) 4 (ppr sty inferred_ty) - ]) +unboxedTupleErr name ty + = hang (ptext SLIT("Illegal binding of unboxed tuple")) + 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- -sigCtxt id sty - = sep [ptext SLIT("When checking signature for"), ppr sty id] -sigsCtxt ids sty - = sep [ptext SLIT("When checking signature(s) for:"), interpp'SP sty ids] +restrictedBindCtxtErr binder_names + = hang (ptext SLIT("Illegal overloaded type signature(s)")) + 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, + ptext SLIT("that falls under the monomorphism restriction")]) ------------------------------------------------ -sigContextsCtxt ty_sigs sty - = hang (ptext SLIT("When matching the contexts of the signatures of a recursive group")) - 4 (vcat (map ppr_tc_ty_sig ty_sigs)) - where - ppr_tc_ty_sig (TySigInfo val _ tyvars theta tau_ty _) - = hang ((<>) (ppr sty val) (ptext SLIT(" :: "))) - 4 (if null theta - then empty - else hcat [parens (hsep (punctuate comma (map (ppr_inst sty) theta))), - text " => ..."]) - ppr_inst sty (clas, ty) = hsep [ppr sty clas, ppr sty ty] - ------------------------------------------------ -specGroundnessCtxt - = panic "specGroundnessCtxt" - --------------------------------------------- -specContextGroundnessCtxt -- err_ctxt dicts sty - = panic "specContextGroundnessCtxt" -{- - = hang ( - sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr sty name], - hcat [ptext SLIT(" specialised to the type"), ppr sty spec_ty], - pp_spec_id sty, - ptext SLIT("... not all overloaded type variables were instantiated"), - ptext SLIT("to ground types:")]) - 4 (vcat [hsep [ppr sty c, ppr sty t] - | (c,t) <- map getDictClassAndType dicts]) - where - (name, spec_ty, locn, pp_spec_id) - = case err_ctxt of - ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> empty) - ValSpecSpecIdCtxt n ty spec loc -> - (n, ty, loc, - \ sty -> hsep [ptext SLIT("... type of explicit id"), ppr sty spec]) --} +genCtxt binder_names + = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names \end{code} - - - -