X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=7d8b4c3b0312c48a0a9d01ed813d8b30e3b4c73d;hb=ff755dd9a0a0ad2f106c323852553ea247f16141;hp=a7a589c7125f3fd5c81024f7b5d747e155bbe0fd;hpb=783e505e2d884f94d30ec8074e590507f2561c49;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index a7a589c..7d8b4c3 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -13,7 +13,7 @@ import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcExpr ) import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..), - collectMonoBinders, andMonoBindList, andMonoBinds + Match(..), collectMonoBinders, andMonoBindList, andMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) @@ -25,7 +25,7 @@ import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), ) import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId, - tcLookupTyCon, + tcLookupTyConByKey, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) @@ -42,8 +42,6 @@ import TcType ( TcType, TcThetaType, ) import TcUnify ( unifyTauTy, unifyTauTyLists ) -import PrelInfo ( main_NAME, ioTyCon_NAME ) - import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars ) import Var ( idType, idName ) import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) @@ -62,7 +60,7 @@ import Util ( isIn ) import Maybes ( maybeToBool ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel ) import FiniteMap ( listToFM, lookupFM ) -import SrcLoc ( SrcLoc ) +import Unique ( ioTyConKey, mainKey, hasKey, Uniquable(..) ) import Outputable \end{code} @@ -259,7 +257,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- come before: -- - computing vars over which to quantify -- - zonking the generalized type vars - tcImprove lie_req `thenTc_` + let lie_avail = case maybe_sig_theta of + Nothing -> emptyLIE + Just (_, la) -> la + lie_avail_req = lie_avail `plusLIE` lie_req in + tcImprove lie_avail_req `thenTc_` -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen -- The tyvars_not_to_gen are free in the environment, and hence @@ -290,7 +292,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- SIMPLIFY THE LIE tcExtendGlobalTyVars tyvars_not_to_gen ( - let ips = getIPsOfLIE lie_req in + let ips = getIPsOfLIE lie_avail_req in if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then -- No polymorphism, and no IPs, so no need to simplify context returnTc (lie_req, EmptyMonoBinds, []) @@ -538,14 +540,20 @@ getTyVarsToGen is_unrestricted mono_id_tys lie zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> let body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars + fds = getAllFunDepsOfLIE lie in if is_unrestricted then - let fds = getAllFunDepsOfLIE lie in + -- We need to augment the type variables that appear explicitly in + -- the type by those that are determined by the functional dependencies. + -- e.g. suppose our type is C a b => a -> a + -- with the fun-dep a->b + -- Then we should generalise over b too; otherwise it will be + -- reported as ambiguous. zonkFunDeps fds `thenNF_Tc` \ fds' -> - let tvFundep = tyVarFunDep fds' - extended_tyvars = oclose tvFundep body_tyvars in - -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $ + let tvFundep = tyVarFunDep fds' + extended_tyvars = oclose tvFundep body_tyvars + in returnNF_Tc (emptyVarSet, extended_tyvars) else -- This recover and discard-errs is to avoid duplicate error @@ -570,13 +578,16 @@ isUnRestrictedGroup :: [Name] -- Signatures given for these 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 (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches || + v `is_elem` sigs isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && isUnRestrictedGroup sigs mb2 isUnRestrictedGroup sigs EmptyMonoBinds = True + +isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature +isUnRestrictedMatch other = True -- Some args or a signature \end{code} @@ -669,7 +680,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec lie_avail1 `plusLIE` lie_avail2) tc_mb_pats (FunMonoBind name inf matches locn) - = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty -> + = new_lhs_ty `thenNF_Tc` \ bndr_ty -> tc_pat_bndr name bndr_ty `thenTc` \ bndr_id -> let complete_it xve = tcAddSrcLoc locn $ @@ -680,13 +691,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec tc_mb_pats bind@(PatMonoBind pat grhss locn) = tcAddSrcLoc locn $ - - -- Figure out the appropriate kind for the pattern, - -- and generate a suitable type variable - (case is_rec of - Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types - NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types - ) `thenNF_Tc` \ pat_ty -> + new_lhs_ty `thenNF_Tc` \ pat_ty -> -- Now typecheck the pattern -- We don't support binding fresh type variables in the @@ -707,6 +712,12 @@ tcMonoBinds mbinds tc_ty_sigs is_rec returnTc (PatMonoBind pat' grhss' locn, lie) in returnTc (complete_it, lie_req, tvs, ids, lie_avail) + + -- Figure out the appropriate kind for the pattern, + -- and generate a suitable type variable + new_lhs_ty = case is_rec of + Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types + NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types \end{code} %************************************************************************ @@ -724,11 +735,12 @@ The error message here is somewhat unsatisfactory, but it'll do for now (ToDo). \begin{code} +checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM s (Maybe (TcThetaType, LIE)) checkSigMatch top_lvl binder_names mono_ids sigs | main_bound_here = -- First unify the main_id with IO t, for any old t tcSetErrCtxt mainTyCheckCtxt ( - tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon -> + tcLookupTyConByKey ioTyConKey `thenTc` \ ioTyCon -> newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> unifyTauTy ((mkTyConApp ioTyCon [t_tv])) (idType main_mono_id) @@ -758,7 +770,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs sig1_dict_tys = mk_dict_tys theta1 n_sig1_dict_tys = length sig1_dict_tys - sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs] + sig_lie = mkLIE (concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]) maybe_main = find_main top_lvl binder_names mono_ids main_bound_here = maybeToBool maybe_main @@ -796,14 +808,14 @@ checkSigMatch top_lvl binder_names mono_ids sigs mk_dict_tys theta = map mkPredTy theta - sig_msg id = ptext SLIT("When checking the type signature for") <+> ppr id + sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id) -- Search for Main.main in the binder_names, return corresponding mono_id find_main NotTopLevel binder_names mono_ids = Nothing find_main TopLevel binder_names mono_ids = go binder_names mono_ids go [] [] = Nothing - go (n:ns) (m:ms) | n == main_NAME = Just m - | otherwise = go ns ms + go (n:ns) (m:ms) | n `hasKey` mainKey = Just m + | otherwise = go ns ms \end{code} @@ -930,13 +942,13 @@ sigContextsCtxt s1 s2 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) mainContextsErr id - | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded") + | id `hasKey` mainKey = ptext SLIT("Main.main cannot be overloaded") | otherwise = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings. mainTyCheckCtxt - = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME), + = hsep [ptext SLIT("When checking that"), quotes (ptext SLIT("main")), ptext SLIT("has the required type")] -----------------------------------------------