#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
+ HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..),
mkMonoBind, nullMonoBinds
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds,
+import TcHsSyn ( TcExpr, TcRecordBinds, mkHsConApp,
mkHsTyApp, mkHsLet, maybeBoxedPrimType
)
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, unitLIE, consLIE, plusLIE, plusLIEs,
- lieToList, listToLIE, tyVarsOfLIE, zonkLIE,
+ lieToList, listToLIE,
newOverloadedLit, newMethod, newIPDict,
instOverloadedFun, newDicts, newClassDicts,
- partitionLIEbyMeth, getIPsOfLIE
+ getIPsOfLIE, instToId, ipToId
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
-import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
+import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
isRecordSelector,
Id, mkVanillaId
)
-import DataCon ( dataConFieldLabels, dataConSig, dataConId,
+import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks, StrictnessMark(..)
)
import Name ( Name, getName )
\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 ->
- returnNF_Tc (HsIPVar id, unitLIE ip)
+ returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
\end{code}
%************************************************************************
later use.
\begin{code}
-tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
+tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
-- 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, _) ->
- returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
- (CCall lbl args' may_gc is_asm result_ty),
+ returnTc (mkHsConApp ioDataCon [result_ty] [HsCCall lbl args' may_gc is_asm result_ty],
-- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
\end{code}
let
(_, record_ty) = splitFunTys con_tau
in
- -- Con is syntactically constrained to be a data constructor
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
unifyTauTy res_ty record_ty `thenTc_`
-- Check that the record bindings match the constructor
+ -- con_name is syntactically constrained to be a data constructor
tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
let
bad_fields = badFields rbinds data_con
tcMonoExpr (HsWith expr binds) res_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
- partitionLIEbyMeth isBound lie `thenTc` \ (ips, lie') ->
- zonkLIE ips `thenTc` \ ips' ->
- tcSimplify (text "With!") (tyVarsOfLIE ips') ips' `thenTc` \ res@(_, dict_binds, _) ->
+ partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) ->
+ pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $
let expr'' = if nullMonoBinds dict_binds
then expr'
- else HsLet (MonoBind dict_binds [] NonRecursive) expr' in
- tcCheckIPBinds binds' types ips' `thenTc_`
- returnTc (HsWith expr'' binds', lie')
+ else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
+ 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_OpenKind `thenTc` \ ty ->
- let id = mkVanillaId name ty in
+ 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) ->