+\begin{code}
+tcMonoBinds :: [LHsBind Name]
+ -> TcSigFun
+ -> RecFlag -- True <=> 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) -> <body>
+ -- 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
projects / ghc-hetmet.git / blobdiff