import BasicTypes ( RecFlag(..), isMarkedStrict )
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
- newOverloadedLit, newMethod, newIPDict,
+ newOverloadedLit, newMethodFromName, newIPDict,
newDicts, newMethodWithGivenTy,
instToId, tcInstCall, tcInstDataCon
)
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, failMName, returnMName, ioTyConName
+ ioTyConName
)
-import Outputable
import ListSetOps ( minusList )
-import Util
import CmdLineOpts
import HscTypes ( TyThing(..) )
+import Util
+import Outputable
+import FastString
\end{code}
%************************************************************************
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}
let
bad_fields = badFields rbinds data_con
in
- if not (null bad_fields) then
+ if notNull bad_fields then
mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
failTc -- Fail now, because tcRecordBinds will crash on a bad field
else
(mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
- checkTcM (not (warn && not (null missing_fields)))
+ checkTcM (not (warn && notNull missing_fields))
(mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
-- STEP 0
-- Check that the field names are really field names
- ASSERT( not (null rbinds) )
+ ASSERT( notNull rbinds )
let
field_names = [field_name | (field_name, _, _) <- rbinds]
in
= unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
- tcLookupGlobalId enumFromName `thenNF_Tc` \ sel_id ->
- newMethod (ArithSeqOrigin seq)
- sel_id [elt_ty] `thenNF_Tc` \ enum_from ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromName `thenNF_Tc` \ enum_from ->
returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
lie1 `plusLIE` unitLIE enum_from)
unifyListTy res_ty `thenTc` \ elt_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` \ enum_from_then ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromThenName `thenNF_Tc` \ enum_from_then ->
returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
(FromThen expr1' expr2'),
unifyListTy res_ty `thenTc` \ elt_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` \ enum_from_to ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromToName `thenNF_Tc` \ enum_from_to ->
returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
(FromTo expr1' expr2'),
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
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` \ eft ->
+ newMethodFromName (ArithSeqOrigin seq)
+ elt_ty enumFromThenToName `thenNF_Tc` \ eft ->
returnTc (ArithSeqOut (HsVar (instToId eft))
(FromThenTo expr1' expr2' expr3'),
unifyPArrTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcLookupGlobalId enumFromToPName `thenNF_Tc` \ sel_id ->
- newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to ->
+ newMethodFromName (PArrSeqOrigin seq)
+ elt_ty enumFromToPName `thenNF_Tc` \ enum_from_to ->
returnTc (PArrSeqOut (HsVar (instToId enum_from_to))
(FromTo expr1' expr2'),
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
- tcLookupGlobalId enumFromThenToPName `thenNF_Tc` \ sel_id ->
- newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft ->
+ newMethodFromName (PArrSeqOrigin seq)
+ elt_ty enumFromThenToPName `thenNF_Tc` \ eft ->
returnTc (PArrSeqOut (HsVar (instToId eft))
(FromThenTo expr1' expr2' expr3'),
%************************************************************************
\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( not (null 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 undefined 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( not (null 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.
--
- tcLookupGlobalId returnMName `thenNF_Tc` \ return_sel_id ->
- tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id ->
- tcLookupGlobalId failMName `thenNF_Tc` \ fail_sel_id ->
- newMethod DoOrigin return_sel_id [tc_ty] `thenNF_Tc` \ return_inst ->
- newMethod DoOrigin then_sel_id [tc_ty] `thenNF_Tc` \ then_inst ->
- newMethod DoOrigin fail_sel_id [tc_ty] `thenNF_Tc` \ fail_inst ->
- let
- monad_lie = mkLIE [return_inst, then_inst, fail_inst]
- in
- returnTc (HsDoOut do_or_lc stmts'
- (instToId return_inst) (instToId then_inst) (instToId fail_inst)
- res_ty src_loc,
- stmts_lie `plusLIE` monad_lie)
+ mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names `thenNF_Tc` \ insts ->
+
+ 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)