X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=b846c0a3f1ea4f5840c64e8026780a06ce5fa5e7;hb=6a18febcb53d54c077da905ac8e233b932516dc5;hp=6243fc6a32dbdec0c07276cb38dbcae175bc4fca;hpb=ac95e0c65cf102927cd3235f9c9e697050caec7b;p=ghc-hetmet.git 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)