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,
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
-import TysWiredIn ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
+import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
import PrelNames ( cCallableClassName,
cReturnableClassName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- thenMName, bindMName, failMName, returnMName, ioTyConName
+ ioTyConName
)
-import Outputable
import ListSetOps ( minusList )
-import Util
import CmdLineOpts
import HscTypes ( TyThing(..) )
+import Util
+import Outputable
+import FastString
\end{code}
%************************************************************************
\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) ->
returnTc (co_fn <$> inst_fn expr', lie1 `plusLIE` lie2 `plusLIE` lie3)
+
+tcMonoExpr (HsType ty) res_ty
+ = failWithTc (text "Can't handle type argument:" <+> ppr ty)
+ -- This is the syntax for type applications that I was planning
+ -- but there are difficulties (e.g. what order for type args)
+ -- so it's not enabled yet.
+ -- Can't eliminate it altogether from the parser, because the
+ -- same parser parses *patterns*.
\end{code}
tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
- = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+ = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
[mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts ->
returnNF_Tc arg_dicts -- Actually a singleton bag
- result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
+ result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
in
-- Arguments
\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` \ tc_ty ->
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
+ unifyTauTy res_ty (mkAppTy tc_ty elt_ty) `thenTc_`
- tcStmts (DoCtxt do_or_lc) m_ty stmts `thenTc` \ (stmts', stmts_lie) ->
+ tcStmts (DoCtxt DoExpr) (mkAppTy tc_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 (newMethodFromName DoOrigin tc_ty) method_names `thenNF_Tc` \ insts ->
- returnTc (HsDoOut do_or_lc stmts'
- (map instToId insts)
- res_ty src_loc,
+ returnTc (HsDo DoExpr stmts'
+ (map instToId insts)
+ res_ty src_loc,
stmts_lie `plusLIE` mkLIE insts)
\end{code}
tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
tcLit (HsLitLit s _) res_ty
= tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
- newDicts (LitLitOrigin (_UNPK_ s))
+ newDicts (LitLitOrigin (unpackFS s))
[mkClassPred cCallableClass [res_ty]] `thenNF_Tc` \ dicts ->
returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
projects / ghc-hetmet.git / blobdiff