Commit 4e342297 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-01-25 17:54:24 by simonpj]

------------------------------------
	   Mainly FunDeps (23 Jan 01)
	------------------------------------

This commit re-engineers the handling of functional dependencies.
A functional dependency is no longer an Inst; instead, the necessary
dependencies are snaffled out of their Class when necessary.

As part of this exercise I found that I had to re-work how to do generalisation
in a binding group.  There is rather exhaustive documentation on the new Plan
at the top of TcSimplify.

	******************
	WARNING: I have compiled all the libraries with this new compiler
		 and all looks well, but I have not run many programs.
		 Things may break.  Let me know if so.
	******************

The main changes are these:

1.  typecheck/TcBinds and TcSimplify have a lot of changes due to the
    new generalisation and context reduction story.  There are extensive
    comments at the start of TcSimplify

2.  typecheck/TcImprove is removed altogether.  Instead, improvement is
    interleaved with context reduction (until a fixpoint is reached).
    All this is done in TcSimplify.

3.  types/FunDeps has new exports
	* 'improve' does improvement, returning a list of equations
	* 'grow' and 'oclose' close a list of type variables wrt a set of
	  PredTypes, but in slightly different ways.  Comments in file.

4.  I improved the way in which we check that main::IO t.  It's tidier now.

In addition

*   typecheck/TcMatches:
	a) Tidy up, introducing a common function tcCheckExistentialPat

	b) Improve the typechecking of parallel list comprehensions,
	   which wasn't quite right before.  (see comments with tcStmts)

	WARNING: (b) is untested!  Jeff, you might want to check.

*   Numerous other incidental changes in the typechecker

*   Manuel found that rules don't fire well when you have partial applications
    from overloading.  For example, we may get

	f a (d::Ord a) = let m_g = g a d
			 in
			 \y :: a -> ...(m_g (h y))...

    The 'method' m_g doesn't get inlined because (g a d) might be a redex.
    Yet a rule that looks like
		g a d (h y) = ...
    won't fire because that doesn't show up.  One way out would be to make
    the rule matcher a bit less paranoid about duplicating work, but instead
    I've added a flag
			-fno-method-sharing
    which controls whether we generate things like m_g in the first place.
    It's not clear that they are a win in the first place.

    The flag is actually consulted in Inst.tcInstId
parent 902b9e87
......@@ -7,7 +7,73 @@
* Do we want to record a package name in a .hi file?
Does pi_mod have a ModuleName or a Module?
* Does teh finder
------------------------------------
Mainly FunDeps (23 Jan 01)
------------------------------------
This commit re-engineers the handling of functional dependencies.
A functional dependency is no longer an Inst; instead, the necessary
dependencies are snaffled out of their Class when necessary.
As part of this exercise I found that I had to re-work how to do generalisation
in a binding group. There is rather exhaustive documentation on the new Plan
at the top of TcSimplify.
******************
WARNING: I have compiled all the libraries with this new compiler
and all looks well, but I have not run many programs.
Things may break. Let me know if so.
******************
The main changes are these:
1. typecheck/TcBinds and TcSimplify have a lot of changes due to the
new generalisation and context reduction story. There are extensive
comments at the start of TcSimplify
2. typecheck/TcImprove is removed altogether. Instead, improvement is
interleaved with context reduction (until a fixpoint is reached).
All this is done in TcSimplify.
3. types/FunDeps has new exports
* 'improve' does improvement, returning a list of equations
* 'grow' and 'oclose' close a list of type variables wrt a set of
PredTypes, but in slightly different ways. Comments in file.
4. I improved the way in which we check that main::IO t. It's tidier now.
In addition
* typecheck/TcMatches:
a) Tidy up, introducing a common function tcCheckExistentialPat
b) Improve the typechecking of parallel list comprehensions,
which wasn't quite right before. (see comments with tcStmts)
WARNING: (b) is untested! Jeff, you might want to check.
* Numerous other incidental changes in the typechecker
* Manuel found that rules don't fire well when you have partial applications
from overloading. For example, we may get
f a (d::Ord a) = let m_g = g a d
in
\y :: a -> ...(m_g (h y))...
The 'method' m_g doesn't get inlined because (g a d) might be a redex.
Yet a rule that looks like
g a d (h y) = ...
won't fire because that doesn't show up. One way out would be to make
the rule matcher a bit less paranoid about duplicating work, but instead
I've added a flag
-fno-method-sharing
which controls whether we generate things like m_g in the first place.
It's not clear that they are a win in the first place.
The flag is actually consulted in Inst.tcInstId
------------------------------------
Mainly PredTypes (28 Sept 00)
......
......@@ -54,6 +54,7 @@ module CmdLineOpts (
opt_NoMonomorphismRestriction,
-- optimisation opts
opt_NoMethodSharing,
opt_DoSemiTagging,
opt_FoldrBuildOn,
opt_LiberateCaseThreshold,
......@@ -437,6 +438,7 @@ opt_Parallel = lookUp SLIT("-fparallel")
opt_SMP = lookUp SLIT("-fsmp")
-- optimisation opts
opt_NoMethodSharing = lookUp SLIT("-fno-method-sharing")
opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging")
opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on")
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
......
This diff is collapsed.
This diff is collapsed.
......@@ -24,16 +24,16 @@ import RnHsSyn ( RenamedTyClDecl,
)
import TcHsSyn ( TcMonoBinds )
import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
newDicts, newMethod )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
instToId, newDicts, newMethod )
import TcEnv ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars )
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
......@@ -435,32 +435,30 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
let
theta = [(mkClassPred clas inst_tys)]
in
newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
newDicts origin theta `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths tyvars clas_tyvars (
tcMethodBind clas origin clas_tyvars inst_tys theta
binds_in prags False op_item
) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
) `thenTc` \ (defm_bind, insts_needed, local_dm_inst) ->
tcAddErrCtxt (defltMethCtxt clas) $
-- tcMethodBind has checked that the class_tyvars havn't
-- been unified with each other or another type, but we must
-- still zonk them before passing them to tcSimplifyAndCheck
zonkTcSigTyVars clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
-- Check the context
tcSimplifyAndCheck
tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
(mkVarSet clas_tyvars')
this_dict
insts_needed `thenTc` \ (const_lie, dict_binds) ->
clas_tyvars
[this_dict]
insts_needed `thenTc` \ (const_lie, dict_binds) ->
-- Simplification can do unification
checkSigTyVars clas_tyvars emptyVarSet `thenTc` \ clas_tyvars' ->
let
full_bind = AbsBinds
clas_tyvars'
[this_dict_id]
[(clas_tyvars', dm_id, local_dm_id)]
[instToId this_dict]
[(clas_tyvars', dm_id, instToId local_dm_inst)]
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
......@@ -498,18 +496,20 @@ tcMethodBind
-> [RenamedSig] -- Pramgas (just for this one)
-> Bool -- True <=> This method is from an instance declaration
-> ClassOpItem -- The method selector and default-method Id
-> TcM (TcMonoBinds, LIE, (LIE, TcId))
-> TcM (TcMonoBinds, LIE, Inst)
tcMethodBind clas origin inst_tyvars inst_tys inst_theta
meth_binds prags is_inst_decl (sel_id, dm_info)
= tcGetSrcLoc `thenNF_Tc` \ loc ->
newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) ->
mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
newMethod origin sel_id inst_tys `thenNF_Tc` \ meth ->
let
meth_id = instToId meth
meth_name = idName meth_id
sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id
meth_prags = find_prags (idName sel_id) meth_name prags
in
mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
-- Figure out what method binding to use
-- If the user suppplied one, use it, else construct a default one
(case find_bind (idName sel_id) meth_name meth_binds of
......
......@@ -19,15 +19,15 @@ module TcEnv(
tcLookupGlobal_maybe, tcLookupGlobal,
-- Local environment
tcExtendKindEnv,
tcExtendKindEnv, tcLookupLocalIds,
tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
tcExtendLocalValEnv, tcLookup,
tcExtendLocalValEnv, tcLookup, tcLookup_maybe,
-- Global type variables
tcGetGlobalTyVars, tcExtendGlobalTyVars,
-- Random useful things
RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, tcInstId,
RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe,
-- New Ids
newLocalId, newSpecPragmaId,
......@@ -41,8 +41,8 @@ module TcEnv(
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import TcMonad
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet,
zonkTcTyVarsAndFV
)
import Id ( idName, mkUserLocal, isDataConWrapId_maybe )
import IdInfo ( constantIdInfo )
......@@ -51,13 +51,11 @@ import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import VarSet
import Type ( Type,
tyVarsOfTypes, splitDFunTy,
splitForAllTys, splitRhoTy,
getDFunTyKey, tyConAppTyCon
)
import DataCon ( DataCon )
import TyCon ( TyCon )
import Class ( Class, ClassOpItem, ClassContext )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, getSrcLoc, mkLocalName,
isLocalName, nameModule_maybe
......@@ -221,33 +219,6 @@ tcLookupRecId env name = case lookup_global env name of
Nothing -> pprPanic "tcLookupRecId" (ppr name)
\end{code}
%************************************************************************
%* *
\subsection{Random useful functions}
%* *
%************************************************************************
\begin{code}
-- A useful function that takes an occurrence of a global thing
-- and instantiates its type with fresh type variables
tcInstId :: Id
-> NF_TcM ([TcTyVar], -- It's instantiated type
TcThetaType, --
TcType) --
tcInstId id
= let
(tyvars, rho) = splitForAllTys (idType id)
in
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
let
rho' = substTy tenv rho
(theta', tau') = splitRhoTy rho'
in
returnNF_Tc (tyvars', theta', tau')
\end{code}
%************************************************************************
%* *
\subsection{Making new Ids}
......@@ -339,8 +310,8 @@ tcLookupGlobalId :: Name -> NF_TcM Id
tcLookupGlobalId name
= tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
case maybe_id of
Just (AnId clas) -> returnNF_Tc clas
other -> notFound "tcLookupGlobalId" name
Just (AnId id) -> returnNF_Tc id
other -> notFound "tcLookupGlobalId" name
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
......@@ -363,6 +334,15 @@ tcLookupTyCon name
case maybe_tc of
Just (ATyCon tc) -> returnNF_Tc tc
other -> notFound "tcLookupTyCon" name
tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
tcLookupLocalIds ns
= tcGetEnv `thenNF_Tc` \ env ->
returnNF_Tc (map (lookup (tcLEnv env)) ns)
where
lookup lenv name = case lookupNameEnv lenv name of
Just (ATcId id) -> id
other -> pprPanic "tcLookupLocalIds" (ppr name)
\end{code}
......@@ -472,13 +452,10 @@ the environment.
tcGetGlobalTyVars :: NF_TcM TcTyVarSet
tcGetGlobalTyVars
= tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs ->
zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
let
global_tvs' = (tyVarsOfTypes global_tys')
in
tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_`
returnNF_Tc global_tvs'
tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
returnNF_Tc gbl_tvs'
\end{code}
......
......@@ -9,23 +9,22 @@ module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
MonoBinds(..), StmtCtxt(..),
mkMonoBind, nullMonoBinds
StmtCtxt(..), mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds, mkHsTyApp, mkHsLet )
import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet )
import TcMonad
import BasicTypes ( RecFlag(..) )
import Inst ( InstOrigin(..),
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethod, newIPDict,
instOverloadedFun, newDicts, newClassDicts,
getIPsOfLIE, instToId, ipToId
newDicts, newClassDicts,
instToId, tcInstId
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( TcTyThing(..), tcInstId,
import TcEnv ( TcTyThing(..),
tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
tcLookupTyCon, tcLookupDataCon, tcLookup,
tcExtendGlobalTyVars
......@@ -33,23 +32,20 @@ import TcEnv ( TcTyThing(..), tcInstId,
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon, simpleHsLitTy )
import TcSimplify ( tcSimplifyAndCheck, partitionPredsOfLIE )
import TcImprove ( tcImprove )
import TcSimplify ( tcSimplifyCheck, tcSimplifyIPs )
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
tcInstTyVars, tcInstType,
newTyVarTy, newTyVarTys, zonkTcType )
import FieldLabel ( fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( idType, recordSelectorFieldLabel, isRecordSelector, mkVanillaId )
import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks, StrictnessMark(..)
)
import Name ( Name, getName )
import Type ( mkFunTy, mkAppTy, mkTyVarTys, ipName_maybe,
import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyConTy,
splitFunTy_maybe, splitFunTys,
mkTyConApp, splitSigmaTy,
splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
liftedTypeKind, openTypeKind, mkArrowKind,
......@@ -57,8 +53,8 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTys, ipName_maybe,
)
import TyCon ( TyCon, tyConTyVars )
import Subst ( mkTopTyVarSubst, substClasses, substTy )
import VarSet ( elemVarSet, mkVarSet )
import TysWiredIn ( boolTy )
import VarSet ( elemVarSet )
import TysWiredIn ( boolTy, mkListTy, listTyCon )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import PrelNames ( cCallableClassName,
cReturnableClassName,
......@@ -115,10 +111,9 @@ tcPolyExpr arg expected_arg_ty
-- To ensure that the forall'd type variables don't get unified with each
-- other or any other types, we make fresh copy of the alleged type
tcInstTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
tcInstType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_theta, sig_tau) ->
let
(sig_theta, sig_tau) = splitRhoTy sig_rho
free_tyvars = tyVarsOfType expected_arg_ty
free_tvs = tyVarsOfType expected_arg_ty
in
-- Type-check the arg and unify with expected type
tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
......@@ -134,25 +129,23 @@ tcPolyExpr arg expected_arg_ty
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
tcExtendGlobalTyVars free_tyvars $
tcExtendGlobalTyVars free_tvs $
tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau) $
checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars ->
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
tcImprove (sig_dicts `plusLIE` lie_arg) `thenTc_`
-- ToDo: better origin
tcSimplifyAndCheck
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ sig_dicts ->
tcSimplifyCheck
(text "the type signature of an expression")
(mkVarSet zonked_sig_tyvars)
sig_tyvars
sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
checkSigTyVars sig_tyvars free_tvs `thenTc` \ zonked_sig_tyvars ->
let
-- This HsLet binds any Insts which came out of the simplification.
-- It's a bit out of place here, but using AbsBind involves inventing
-- a couple of new names which seems worse.
generalised_arg = TyLam zonked_sig_tyvars $
DictLam dict_ids $
DictLam (map instToId sig_dicts) $
mkHsLet inst_binds $
arg'
in
......@@ -188,10 +181,7 @@ tcMonoExpr (HsVar name) res_ty
\begin{code}
tcMonoExpr (HsIPVar name) res_ty
-- ZZ What's the `id' used for here...
= let id = mkVanillaId name res_ty in
tcGetInstLoc (OccurrenceOf id) `thenNF_Tc` \ loc ->
newIPDict name res_ty loc `thenNF_Tc` \ ip ->
= newIPDict (IPOcc name) name res_ty `thenNF_Tc` \ ip ->
returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
\end{code}
......@@ -279,7 +269,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
let
new_arg_dict (arg, arg_ty)
= newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
[(cCallableClass, [arg_ty])] `thenNF_Tc` \ (arg_dicts, _) ->
[(cCallableClass, [arg_ty])] `thenNF_Tc` \ arg_dicts ->
returnNF_Tc arg_dicts -- Actually a singleton bag
result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
......@@ -305,9 +295,9 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ ccres_dict ->
returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie)
\end{code}
\begin{code}
......@@ -544,11 +534,11 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
inst_env = mkTopTyVarSubst tyvars result_inst_tys
theta' = substClasses inst_env theta
in
newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts ->
-- Phew!
returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
returnTc (RecordUpdOut record_expr' result_record_ty (map instToId dicts) rbinds',
mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie)
tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
= unifyListTy res_ty `thenTc` \ elt_ty ->
......@@ -556,10 +546,10 @@ tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
tcLookupGlobalId enumFromName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
sel_id [elt_ty] `thenNF_Tc` \ enum_from ->
returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
lie1 `plusLIE` lie2)
returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
lie1 `plusLIE` unitLIE enum_from)
tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
= tcAddErrCtxt (arithSeqCtxt in_expr) $
......@@ -567,11 +557,11 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcLookupGlobalId enumFromThenName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_then ->
returnTc (ArithSeqOut (HsVar enum_from_then_id)
(FromThen expr1' expr2'),
lie1 `plusLIE` lie2 `plusLIE` lie3)
returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
(FromThen expr1' expr2'),
lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_then)
tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
= tcAddErrCtxt (arithSeqCtxt in_expr) $
......@@ -579,11 +569,11 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcLookupGlobalId enumFromToName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to ->
returnTc (ArithSeqOut (HsVar enum_from_to_id)
returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
(FromTo expr1' expr2'),
lie1 `plusLIE` lie2 `plusLIE` lie3)
lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to)
tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
= tcAddErrCtxt (arithSeqCtxt in_expr) $
......@@ -592,11 +582,11 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
tcLookupGlobalId enumFromThenToName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft ->
returnTc (ArithSeqOut (HsVar eft_id)
(FromThenTo expr1' expr2' expr3'),
lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
returnTc (ArithSeqOut (HsVar (instToId eft))
(FromThenTo expr1' expr2' expr3'),
lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft)
\end{code}
%************************************************************************
......@@ -627,7 +617,7 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
-- If everything is ok, return the stuff unchanged, except for
-- the effect of any substutions etc. We simply discard the
-- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
-- result of the tcSimplifyCheck (inside tcPolyExpr), except for any default
-- resolution it may have done, which is recorded in the
-- substitution.
returnTc (expr, lie)
......@@ -637,52 +627,21 @@ Implicit Parameter bindings.
\begin{code}
tcMonoExpr (HsWith expr binds) res_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) ->
let expr'' = if nullMonoBinds dict_binds
then expr'
else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
expr'
= tcMonoExpr expr res_ty `thenTc` \ (expr', expr_lie) ->
mapAndUnzipTc tcIPBind binds `thenTc` \ (pairs, bind_lies) ->
tcSimplifyIPs (map fst binds) expr_lie `thenTc` \ (expr_lie', dict_binds) ->
let
binds' = [(instToId ip, rhs) | (ip,rhs) <- pairs]
expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
in
tcCheckIPBinds binds' types ips `thenTc_`
returnTc (HsWith expr'' binds', lie' `plusLIE` lie2)
where isBound p
= case ipName_maybe p of
Just n -> n `elem` names
Nothing -> False
names = map fst binds
-- revBinds is used because tcSimplify outputs the bindings
-- out-of-order. it's not a problem elsewhere because these
-- bindings are normally used in a recursive let
-- ZZ probably need to find a better solution
revBinds (b1 `AndMonoBinds` b2) =
(revBinds b2) `AndMonoBinds` (revBinds b1)
revBinds b = b
tcIPBinds ((name, expr) : binds)
= newTyVarTy openTypeKind `thenTc` \ ty ->
tcGetSrcLoc `thenTc` \ loc ->
let id = ipToId name ty loc in
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
zonkTcType ty `thenTc` \ ty' ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
returnTc ((id, expr') : binds', ty : types, lie `plusLIE` lie2)
tcIPBinds [] = returnTc ([], [], emptyLIE)
tcCheckIPBinds binds types ips
= foldrTc tcCheckIPBind (getIPsOfLIE ips) (zip binds types)
-- ZZ how do we use the loc?
tcCheckIPBind bt@((v, _), t1) ((n, t2) : ips) | getName v == n
= unifyTauTy t1 t2 `thenTc_`
tcCheckIPBind bt ips `thenTc` \ ips' ->
returnTc ips'
tcCheckIPBind bt (ip : ips)
= tcCheckIPBind bt ips `thenTc` \ ips' ->
returnTc (ip : ips')
tcCheckIPBind bt []
= returnTc []
returnTc (HsWith expr'' binds', expr_lie' `plusLIE` plusLIEs bind_lies)
tcIPBind (name, expr)
= newTyVarTy openTypeKind `thenTc` \ ty ->
tcGetSrcLoc `thenTc` \ loc ->
newIPDict (IPBind name) name ty `thenNF_Tc` \ ip ->
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
returnTc ((ip, expr'), lie)
\end{code}
Typecheck expression which in most cases will be an Id.
......@@ -798,32 +757,8 @@ tcId name
= -- Look up the Id and instantiate its type
tcLookup name `thenNF_Tc` \ thing ->
case thing of
ATcId tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (idType tc_id)
AGlobal (AnId id) -> tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
instantiate_it2 (OccurrenceOf id) id tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
-- It has to be a loop because we are now prepared to entertain
-- types like
-- f:: forall a. Eq a => forall b. Baz b => tau
-- We want to instantiate this to
-- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
instantiate_it orig fun ty
= tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
instantiate_it2 orig fun tyvars theta tau
instantiate_it2 orig fun tyvars theta tau
= if null theta then -- Is it overloaded?
returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
instantiate_it orig fun' tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
where
arg_tys = mkTyVarTys tyvars
ATcId tc_id -> tcInstId tc_id
AGlobal (AnId id) -> tcInstId id
\end{code}
%************************************************************************
......@@ -839,18 +774,20 @@ tcDoStmts do_or_lc stmts src_loc res_ty
ASSERT( not (null stmts) )
tcAddSrcLoc src_loc $
newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m ->
newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
-- If it's a comprehension we're dealing with,
-- force it to be a list comprehension.
-- (as of Haskell 98, monad comprehensions are no more.)