import TcHsSyn ( TcPat(..), TcIdOcc(..) )
import TcMonad
-import Inst ( Inst, OverloadedLit(..), InstOrigin(..), LIE(..),
- emptyLIE, plusLIE, newMethod, newOverloadedLit )
+import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
+ emptyLIE, plusLIE, plusLIEs, LIE(..),
+ newMethod, newOverloadedLit
+ )
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcLookupLocalValueOK )
+ tcLookupLocalValueOK, tcGlobalOcc )
import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
-import ErrUtils ( arityErr )
import Id ( GenId, idType )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
+import Maybes ( maybeToBool )
import Name ( Name )
import PprType ( GenType, GenTyVar )
import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, charTy, stringTy, mkListTy,
mkTupleTy, addrTy, addrPrimTy )
import Pretty
-import Type ( Type(..), GenType, splitFunTy, splitSigmaTy )
+import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
+ getFunTy_maybe, maybeAppDataTyCon,
+ Type(..), GenType
+ )
import TyVar ( GenTyVar )
import Unique ( Unique, eqClassOpKey )
-
+import Util ( assertPanic, panic{-ToDo:rm-} )
\end{code}
\begin{code}
\begin{code}
tcPat pat_in@(ConPatIn name pats)
- = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
-
- tcPats pats `thenTc` \ (pats', lie, tys) ->
+ = tcPats pats `thenTc` \ (pats', lie, tys) ->
tcAddErrCtxt (patCtxt pat_in) $
- matchConArgTys con_id tys `thenTc` \ data_ty ->
+ matchConArgTys name tys `thenTc` \ (con_id, data_ty) ->
returnTc (ConPat con_id data_ty pats',
lie,
data_ty)
tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
- = tcLookupGlobalValue op `thenNF_Tc` \ con_id ->
-
- tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
+ = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
tcAddErrCtxt (patCtxt pat_in) $
- matchConArgTys con_id [ty1,ty2] `thenTc` \ data_ty ->
+ matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
returnTc (ConOpPat pat1' con_id pat2' data_ty,
lie1 `plusLIE` lie2,
%************************************************************************
%* *
+\subsection{Records}
+%* *
+%************************************************************************
+
+\begin{code}
+tcPat pat_in@(RecPatIn name rpats)
+ = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) ->
+ let
+ (_, con_tau) = splitRhoTy con_rho
+ -- Ignore the con_theta; overloaded constructors only
+ -- behave differently when called, not when used for
+ -- matching.
+ (_, record_ty) = splitFunTy con_tau
+ in
+ -- Con is syntactically constrained to be a data constructor
+ ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
+
+ mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
+
+ returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats',
+ plusLIEs lies,
+ record_ty-})
+
+ where
+ do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
+ = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
+
+ -- Record selectors all have type
+ -- forall a1..an. T a1 .. an -> tau
+ ASSERT( maybeToBool (getFunTy_maybe tau) )
+ let
+ -- Selector must have type RecordType -> FieldType
+ Just (record_ty, field_ty) = getFunTy_maybe tau
+ in
+ tcAddErrCtxt (recordLabel field_label) (
+ unifyTauTy expected_record_ty record_ty
+ ) `thenTc_`
+ tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) ->
+ tcAddErrCtxt (recordRhs field_label rhs_pat) (
+ unifyTauTy field_ty rhs_ty
+ ) `thenTc_`
+ returnTc ((sel_id, rhs_pat', pun_flag), lie)
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Non-overloaded literals}
%* *
%************************************************************************
unifies the actual args against the expected ones.
\begin{code}
-matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s)
+matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
-matchConArgTys con_id arg_tys
- = tcInstType [] (idType con_id) `thenNF_Tc` \ con_ty ->
+matchConArgTys con arg_tys
+ = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) ->
let
- no_of_args = length arg_tys
- (con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty
- -- Ignore the sig_theta; overloaded constructors only
+ (con_theta, con_tau) = splitRhoTy con_rho
+ -- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
+
(con_args, con_result) = splitFunTy con_tau
con_arity = length con_args
+ no_of_args = length arg_tys
in
checkTc (con_arity == no_of_args)
(arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
unifyTauTyLists arg_tys con_args `thenTc_`
- returnTc con_result
+ returnTc (con_id, con_result)
\end{code}
~~~~~~~~~~~~~~~~~~~
\begin{code}
patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
+
+recordLabel field_label sty
+ = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
+ 4 (ppBesides [ppStr "with its immediately enclosing constructor"])
+
+recordRhs field_label pat sty
+ = ppHang (ppStr "In the record field pattern")
+ 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])
\end{code}
projects / ghc-hetmet.git / blobdiff