#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
+ HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..),
mkMonoBind, nullMonoBinds
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
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,
\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}
%************************************************************************
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) ->