import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr )
-import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
- collectMonoBinders, andMonoBindList, andMonoBinds
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
+ Match(..), collectMonoBinders, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
+import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
-import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
- newDicts, tyVarsOfInst, instToId, getFunDepsOfLIE,
- zonkFunDeps
+import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
+ newDicts, tyVarsOfInst, instToId,
+ getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
- tcLookupTyCon,
+ tcLookupTyConByKey,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
import TcImprove ( tcImprove )
-import TcMonoType ( tcHsType, checkSigTyVars,
+import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( TcType, TcThetaType,
- TcTyVar,
- newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
- zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+import TcType ( TcThetaType, newTyVarTy, newTyVar,
+ zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
)
import TcUnify ( unifyTauTy, unifyTauTyLists )
-import PrelInfo ( main_NAME, ioTyCon_NAME )
-
-import Id ( Id, mkVanillaId, setInlinePragma )
+import Id ( mkVanillaId, setInlinePragma, idFreeTyVars )
import Var ( idType, idName )
-import IdInfo ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) )
-import Name ( Name, getName, getOccName, getSrcLoc )
+import IdInfo ( InlinePragInfo(..) )
+import Name ( Name, getOccName, getSrcLoc )
import NameSet
import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
- splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
- mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
- isUnboxedType, unboxedTypeKind, boxedTypeKind
+ mkForAllTys, mkFunTys,
+ mkPredTy, mkForAllTy, isUnLiftedType,
+ isUnboxedType, unboxedTypeKind, boxedTypeKind, openTypeKind
)
import FunDeps ( tyVarFunDep, oclose )
-import Var ( TyVar, tyVarKind )
+import Var ( tyVarKind )
import VarSet
import Bag
import Util ( isIn )
import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
import FiniteMap ( listToFM, lookupFM )
-import SrcLoc ( SrcLoc )
+import PrelNames ( ioTyConKey, mainKey, hasKey )
import Outputable
\end{code}
newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
- binder_names = map fst (bagToList (collectMonoBinders mbind))
+ binder_names = collectMonoBinders mbind
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
-- 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
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
- if null real_tyvars_to_gen_list then
- -- No polymorphism, so no need to simplify context
+ 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, [])
else
case maybe_sig_theta of
-- NB: no signatures => no polymorphic recursion, so no
-- need to use lie_avail (which will be empty anyway)
tcSimplify (text "tcBinds1" <+> ppr binder_names)
- top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+ real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
Just (sig_theta, lie_avail) ->
-- at all.
pat_binders :: [Name]
- pat_binders = map fst $ bagToList $ collectMonoBinders $
- (justPatBindings mbind EmptyMonoBinds)
+ pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
in
-- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
mapTc (\id -> checkTc (not (idName id `elem` pat_binders
-- BUILD RESULTS
returnTc (
+ -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
AbsBinds real_tyvars_to_gen_list
dicts_bound
exports
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 = concatMap snd (getFunDepsOfLIE 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
recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars)) $
discardErrsTc $
- tcSimplify (text "getTVG") NotTopLevel body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
+ tcSimplify (text "getTVG") body_tyvars lie `thenTc` \ (_, _, constrained_dicts) ->
let
-- ASSERT: dicts_sig is already zonked!
constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
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}
tcMonoBinds mbinds tc_ty_sigs is_rec
= tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
let
- tv_list = bagToList tvs
id_list = bagToList ids
(names, mono_ids) = unzip id_list
lie_avail1 `plusLIE` lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
- = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
+ = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
let
complete_it xve = tcAddSrcLoc locn $
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 ->
+ newTyVarTy kind `thenNF_Tc` \ pat_ty ->
-- Now typecheck the pattern
-- We don't support binding fresh type variables in the
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
+ kind = case is_rec of
+ Recursive -> boxedTypeKind -- Recursive, so no unboxed types
+ NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
\end{code}
%************************************************************************
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)
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
-- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
-- Doesn't affect substitution
- check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+ check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
= tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
- checkSigTyVars sig_tyvars
+ tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
+ checkSigTyVars sig_tyvars (idFreeTyVars id)
-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
= tcAddSrcLoc src_loc $
checkTc (null theta) (mainContextsErr id)
- mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+ mk_dict_tys theta = map mkPredTy theta
- sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
- nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+ 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}
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsType poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
-notAsPolyAsSigErr sig_tau mono_tyvars
- = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
- 4 (vcat [text "Can't for-all the type variable(s)" <+>
- pprQuotedList mono_tyvars,
- text "in the type" <+> quotes (ppr sig_tau)
- ])
-
------------------------------------------------
-badMatchErr sig_ty inferred_ty
- = hang (ptext SLIT("Type signature doesn't match inferred type"))
- 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
- hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
- ])
-
------------------------------------------------
unboxedPatBindErr id
= ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
<+> quotes (ppr id)
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")]
-----------------------------------------------
projects / ghc-hetmet.git / blobdiff