#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsMatchContext(..), HsDoContext(..),
- mkMonoBind
+ HsMatchContext(..), HsDoContext(..), MonoBinds(..),
+ mkMonoBind, andMonoBindList
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy, mkHsDictApp, mkHsTyApp )
+import TcHsSyn ( TcExpr, TcRecordBinds, TypecheckedMonoBinds,
+ simpleHsLitTy, mkHsDictApp, mkHsTyApp, mkHsLet )
import TcMonad
import TcUnify ( tcSubExp, tcGen, (<$>),
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethodFromName, newIPDict,
- newDicts, newMethodWithGivenTy,
+ newDicts, newMethodWithGivenTy, tcSyntaxName,
instToId, tcInstCall, tcInstDataCon
)
import TcBinds ( tcBindsAndThen )
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
- isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, mkFunTys,
+ isSigmaTy, mkFunTy, mkAppTy, mkFunTys,
mkTyConApp, mkClassPred, tcFunArgTy,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind, mkArrowKind,
tidyOpenType
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
-import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
+import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector,
+ isDataConWrapId_maybe, mkSysLocal )
import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks
)
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
-import TysWiredIn ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
-import PrelNames ( cCallableClassName,
- cReturnableClassName,
+import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
+import PrelNames ( cCallableClassName, cReturnableClassName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- thenMName, bindMName, failMName, returnMName, ioTyConName
+ ioTyConName, monadNames
)
import ListSetOps ( minusList )
import CmdLineOpts
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
+ = tcAddErrCtxt (exprSigCtxt in_expr) $
+ tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
tcExpr expr sig_tc_ty `thenTc` \ (expr', lie1) ->
-- Must instantiate the outer for-alls of sig_tc_ty
-- else we risk instantiating a ? res_ty to a forall-type
-- which breaks the invariant that tcMonoExpr only returns phi-types
- tcAddErrCtxt (exprSigCtxt in_expr) $
tcInstCall SignatureOrigin sig_tc_ty `thenNF_Tc` \ (inst_fn, lie2, inst_sig_ty) ->
tcSubExp res_ty inst_sig_ty `thenTc` \ (co_fn, lie3) ->
\end{code}
\begin{code}
-tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
- = tcDoStmts do_or_lc stmts src_loc res_ty
+tcMonoExpr expr@(HsDo do_or_lc stmts method_names _ src_loc) res_ty
+ = tcAddSrcLoc src_loc (tcDoStmts do_or_lc stmts method_names src_loc res_ty)
\end{code}
\begin{code}
%************************************************************************
\begin{code}
--- I don't like this lumping together of do expression and list/array
--- comprehensions; creating the monad instances is entirely pointless in the
--- latter case; I'll leave the list case as it is for the moment, but handle
--- arrays extra (would be better to handle arrays and lists together, though)
--- -=chak
---
-tcDoStmts PArrComp stmts src_loc res_ty
- =
- ASSERT( notNull stmts )
- tcAddSrcLoc src_loc $
-
- unifyPArrTy res_ty `thenTc` \elt_ty ->
- let tc_ty = mkTyConTy parrTyCon
- m_ty = (mkPArrTy, elt_ty)
- in
- tcStmts (DoCtxt PArrComp) m_ty stmts `thenTc` \(stmts', stmts_lie) ->
- returnTc (HsDoOut PArrComp stmts'
- undefined -- don't touch!
- res_ty src_loc,
+tcDoStmts PArrComp stmts method_names src_loc res_ty
+ = unifyPArrTy res_ty `thenTc` \elt_ty ->
+ tcStmts (DoCtxt PArrComp)
+ (mkPArrTy, elt_ty) stmts `thenTc` \(stmts', stmts_lie) ->
+ returnTc (HsDo PArrComp stmts'
+ [] -- Unused
+ res_ty src_loc,
stmts_lie)
-tcDoStmts do_or_lc stmts src_loc res_ty
- = -- get the Monad and MonadZero classes
- -- create type consisting of a fresh monad tyvar
- ASSERT( notNull stmts )
- tcAddSrcLoc src_loc $
-
- -- 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.)
- -- Similarily, array comprehensions must involve parallel arrays types
- -- -=chak
- (case do_or_lc of
- ListComp -> unifyListTy res_ty `thenTc` \ elt_ty ->
- returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
-
- PArrComp -> panic "TcExpr.tcDoStmts: How did we get here?!?"
+tcDoStmts ListComp stmts method_names src_loc res_ty
+ = unifyListTy res_ty `thenTc` \ elt_ty ->
+ tcStmts (DoCtxt ListComp)
+ (mkListTy, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (HsDo ListComp stmts'
+ [] -- Unused
+ res_ty src_loc,
+ stmts_lie)
- _ -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
- newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
- returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
- ) `thenNF_Tc` \ (tc_ty, m_ty) ->
+tcDoStmts DoExpr stmts method_names src_loc res_ty
+ = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
+ unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
- tcStmts (DoCtxt do_or_lc) m_ty stmts `thenTc` \ (stmts', stmts_lie) ->
+ tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
--
- mapNF_Tc (newMethodFromName DoOrigin tc_ty)
- [returnMName, failMName, bindMName, thenMName] `thenNF_Tc` \ insts ->
+ mapNF_Tc (tc_syn_name m_ty)
+ (zipEqual "tcDoStmts" monadNames method_names) `thenNF_Tc` \ stuff ->
+ let
+ (binds, ids, lies) = unzip3 stuff
+ in
- returnTc (HsDoOut do_or_lc stmts'
- (map instToId insts)
- res_ty src_loc,
- stmts_lie `plusLIE` mkLIE insts)
-\end{code}
+ returnTc (mkHsLet (andMonoBindList binds) $
+ HsDo DoExpr stmts' ids
+ res_ty src_loc,
+ stmts_lie `plusLIE` plusLIEs lies)
+ where
+ tc_syn_name :: TcType -> (Name,Name) -> TcM (TypecheckedMonoBinds, Id, LIE)
+ tc_syn_name m_ty (std_nm, usr_nm)
+ = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenTc` \ (expr, lie, expr_ty) ->
+ case expr of
+ HsVar v -> returnTc (EmptyMonoBinds, v, lie)
+ other -> tcGetUnique `thenTc` \ uniq ->
+ let
+ id = mkSysLocal FSLIT("syn") uniq expr_ty
+ in
+ returnTc (VarMonoBind id expr, id, lie)
+\end{code}
%************************************************************************
%* *
= hang (ptext SLIT("When checking the type signature of the expression:"))
4 (ppr expr)
+exprCtxt expr
+ = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
+
+funAppCtxt fun arg arg_no
+ = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
+ quotes (ppr fun) <> text ", namely"])
+ 4 (quotes (ppr arg))
+
listCtxt expr
= hang (ptext SLIT("In the list element:")) 4 (ppr expr)
predCtxt expr
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
-exprCtxt expr
- = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
-
-funAppCtxt fun arg arg_no
- = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
- quotes (ppr fun) <> text ", namely"])
- 4 (quotes (ppr arg))
-
wrongArgsCtxt too_many_or_few fun args
= hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
<+> ptext SLIT("is applied to") <+> text too_many_or_few
projects / ghc-hetmet.git / blobdiff