From: simonpj Date: Thu, 26 May 2005 21:37:13 +0000 (+0000) Subject: [project @ 2005-05-26 21:37:13 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~470 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6a18febcb53d54c077da905ac8e233b932516dc5;p=ghc-hetmet.git [project @ 2005-05-26 21:37:13 by simonpj] MERGE TO STABLE Put back in a missing case for higher-rank types. When the definition is a) non-recursive b) a function binding c) lacks a type signature we want to *infer* a perhaps-higher-rank type for the RHS, before making a monomorphically-typed Id for the LHS. E.g. f = \(x :: forall a. a->a) -> (x True, x 'c') This case got lost in the transition to 6.4 tc194 tests it --- diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 6243fc6..b846c0a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -121,6 +121,7 @@ tcHsBootSigs [HsBindGroup binds sigs _] = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) } -- Notice that we make GlobalIds, not LocalIds +tcHsBootSits groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") @@ -456,6 +457,22 @@ tcMonoBinds :: LHsBinds Name -> TcM (LHsBinds TcId, [MonoBindInfo]) tcMonoBinds binds lookup_sig is_rec + | isNonRec is_rec, -- Non-recursive, single function binding + [L b_loc (FunBind (L nm_loc name) inf matches)] <- bagToList binds, + Nothing <- lookup_sig 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 { (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches) + ; mono_name <- newLocalName name + ; let mono_id = mkLocalId mono_name rhs_ty + ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches')), + [(name, Nothing, mono_id)]) } + + | otherwise = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs @@ -538,6 +555,9 @@ tcLhs lookup_sig bind@(PatBind pat grhss _) ; return [ (name, lookup_sig name, mono_id) | (name, mono_id) <- names `zip` mono_ids] } +tcLhs lookup_sig other_bind = pprPanic "tcLhs" (ppr other_bind) + -- AbsBind, VarBind impossible + ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)