[project @ 2003-12-10 14:15:16 by simonmar]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcPat.lhs
index 0bf3c31..cf0ec11 100644 (file)
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcPat]{Typechecking patterns}
 
 \begin{code}
+module TcPat ( tcPat, tcMonoPatBndr, tcSubPat,
+              badFieldCon, polyPatSig
+  ) where
+
 #include "HsVersions.h"
 
-module TcPat (
-       tcPat
-#ifdef DPH
-       , tcPats
-#endif
-    ) where
-
-import TcMonad         -- typechecking monad machinery
-import TcMonadFns      ( newOpenTyVarTy, newPolyTyVarTy,
-                         newPolyTyVarTys, copyTyVars, newMethod,
-                         newOverloadedLit
-                       )
-import AbsSyn          -- the stuff being typechecked
-
-import AbsPrel         ( charPrimTy, intPrimTy, floatPrimTy,
-                         doublePrimTy, charTy, stringTy, mkListTy,
-                         mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId
-                         PrimOp
-                         IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-                         IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
-                         ,mkProcessorTy, toDomainId
-#endif {- Data Parallel Haskell -}
-                       )
-import AbsUniType      ( instantiateTauTy, applyTyCon, InstTyEnv(..)
-                         IF_ATTACK_PRAGMAS(COMMA instantiateTy)
-                       )
-import CmdLineOpts     ( GlobalSwitch(..) )
-import Id              ( mkInstId, getIdUniType, getDataConSig,
-                         getInstantiatedDataConSig, Id, DataCon(..)
-                       )
-import Inst
-import E               ( lookupE_Binder, lookupE_Value,
-                         lookupE_ClassOpByKey, E,
-                         LVE(..), TCE(..), UniqFM, CE(..)
-                       -- TCE and CE for pragmas only
-                       )
-import Errors          ( dataConArityErr, Error(..), UnifyErrContext(..)
+import HsSyn           ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) )
+import HsUtils
+import TcHsSyn         ( TcId, hsLitType,
+                         mkCoercion, idCoercion, isIdCoercion,
+                         (<$>), PatCoFn )
+
+import TcRnMonad
+import Inst            ( InstOrigin(..),
+                         newMethodFromName, newOverloadedLit, newDicts,
+                         instToId, tcInstDataCon, tcSyntaxName
                        )
-import LIE             ( nullLIE, plusLIE, mkLIE, LIE )
-import Unify
-import Unique          -- some ClassKey stuff
-import Util
-
-#ifdef DPH
-import TcParQuals
-#endif {- Data Parallel Haskell -}
+import Id              ( idType, mkLocalId, mkSysLocal )
+import Name            ( Name )
+import FieldLabel      ( fieldLabelName )
+import TcEnv           ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId )
+import TcMType                 ( newTyVarTy, arityErr )
+import TcType          ( TcType, TcTyVar, TcSigmaType, 
+                         mkClassPred, liftedTypeKind )
+import TcUnify         ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, 
+                         unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy )  
+import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
+
+import TysWiredIn      ( stringTy )
+import CmdLineOpts     ( opt_IrrefutableTuples )
+import DataCon         ( DataCon, dataConFieldLabels, dataConSourceArity )
+import PrelNames       ( eqStringName, eqName, geName, negateName, minusName, 
+                         integralClassName )
+import BasicTypes      ( isBoxed )
+import SrcLoc          ( Located(..), noLoc, unLoc )
+import Bag
+import Outputable
+import FastString
 \end{code}
 
-The E passed in already contains bindings for all the variables in
-the pattern, usually to fresh type variables (but maybe not, if there
-were type signatures present).
+
+%************************************************************************
+%*                                                                     *
+\subsection{Variable patterns}
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType)
+type BinderChecker = Name -> Expected TcSigmaType -> TcM (PatCoFn, TcId)
+                       -- How to construct a suitable (monomorphic)
+                       -- Id for variables found in the pattern
+                       -- The TcSigmaType is the expected type 
+                       -- from the pattern context
+
+-- The Id may have a sigma type (e.g. f (x::forall a. a->a))
+-- so we want to *create* it during pattern type checking.
+-- We don't want to make Ids first with a type-variable type
+-- and then unify... becuase we can't unify a sigma type with a type variable.
+
+tcMonoPatBndr :: BinderChecker
+  -- This is the right function to pass to tcPat when 
+  -- we're looking at a lambda-bound pattern, 
+  -- so there's no polymorphic guy to worry about
+
+tcMonoPatBndr binder_name pat_ty 
+  = zapExpectedType pat_ty     `thenM` \ pat_ty' ->
+       -- If there are *no constraints* on the pattern type, we
+       -- revert to good old H-M typechecking, making
+       -- the type of the binder into an *ordinary* 
+       -- type variable.  We find out if there are no constraints
+       -- by seeing if we are given an "open hole" as our info.
+       -- What we are trying to avoid here is giving a binder
+       -- a type that is a 'hole'.  The only place holes should
+       -- appear is as an argument to tcPat and tcExpr/tcMonoExpr.
+
+    returnM (idCoercion, mkLocalId binder_name pat_ty')
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Variables, wildcards, lazy pats, as-pats}
+\subsection{Typechecking patterns}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-tcPat e (VarPatIn name)
-  = let
-       id = lookupE_Binder e name
-    in
-    returnTc (VarPat id, nullLIE, getIdUniType id)
+tcPat :: BinderChecker
+      -> LPat Name
+
+      -> Expected TcSigmaType  -- Expected type derived from the context
+                               --      In the case of a function with a rank-2 signature,
+                               --      this type might be a forall type.
+
+      -> TcM   (LPat TcId, 
+               Bag TcTyVar,    -- TyVars bound by the pattern
+                                       --      These are just the existentially-bound ones.
+                                       --      Any tyvars bound by *type signatures* in the
+                                       --      patterns are brought into scope before we begin.
+               Bag (Name, TcId),       -- Ids bound by the pattern, along with the Name under
+                                       --      which it occurs in the pattern
+                                       --      The two aren't the same because we conjure up a new
+                                       --      local name for each variable.
+               [Inst])                 -- Dicts or methods [see below] bound by the pattern
+                                       --      from existential constructor patterns
+tcPat tc_bndr (L span pat) exp_ty
+  = addSrcSpan span $
+    do { (pat', tvs, ids, lie) <- tc_pat tc_bndr pat exp_ty
+       ; return (L span pat', tvs, ids, lie) }
+\end{code}
 
-tcPat e (LazyPatIn pat)
-  = tcPat e pat                `thenTc` \ (pat', lie, ty) ->
-    returnTc (LazyPat pat', lie, ty)
 
-tcPat e pat_in@(AsPatIn name pat)
-  = let
-       id = lookupE_Binder e name
-    in
-    tcPat e pat                                `thenTc` \ (pat', lie, ty) ->
-    unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_`
-    returnTc (AsPat id pat', lie, ty)
+%************************************************************************
+%*                                                                     *
+\subsection{Variables, wildcards, lazy pats, as-pats}
+%*                                                                     *
+%************************************************************************
 
-tcPat e (WildPatIn)
-  = newOpenTyVarTy    `thenNF_Tc` \ tyvar_ty ->
-    returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty)
+\begin{code}
+tc_pat tc_bndr pat@(TypePat ty) pat_ty
+  = failWithTc (badTypePat pat)
+
+tc_pat tc_bndr (VarPat name) pat_ty
+  = tc_bndr name pat_ty                                `thenM` \ (co_fn, bndr_id) ->
+    returnM (co_fn <$> VarPat bndr_id, 
+            emptyBag, unitBag (name, bndr_id), [])
+
+tc_pat tc_bndr (LazyPat pat) pat_ty
+  = tcPat tc_bndr pat pat_ty           `thenM` \ (pat', tvs, ids, lie_avail) ->
+    returnM (LazyPat pat', tvs, ids, lie_avail)
+
+tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty
+  = addSrcSpan nm_loc (tc_bndr name pat_ty)    `thenM` \ (co_fn, bndr_id) ->
+    tcPat tc_bndr pat (Check (idType bndr_id)) `thenM` \ (pat', tvs, ids, lie_avail) ->
+       -- NB: if we have:
+       --      \ (y@(x::forall a. a->a)) = e
+       -- we'll fail.  The as-pattern infers a monotype for 'y', which then
+       -- fails to unify with the polymorphic type for 'x'.  This could be
+       -- fixed, but only with a bit more work.
+    returnM (co_fn <$> (AsPat (L nm_loc bndr_id) pat'), 
+             tvs, (name, bndr_id) `consBag` ids, lie_avail)
+
+tc_pat tc_bndr (WildPat _) pat_ty
+  = zapExpectedType pat_ty             `thenM` \ pat_ty' ->
+       -- We might have an incoming 'hole' type variable; no annotation
+       -- so zap it to a type.  Rather like tcMonoPatBndr.
+    returnM (WildPat pat_ty', emptyBag, emptyBag, [])
+
+tc_pat tc_bndr (ParPat parend_pat) pat_ty
+-- Leave the parens in, so that warnings from the
+-- desugarer have parens in them
+  = tcPat tc_bndr parend_pat pat_ty    `thenM` \ (pat', tvs, ids, lie_avail) ->
+    returnM (ParPat pat', tvs, ids, lie_avail)
+
+tc_pat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
+  = addErrCtxt (patCtxt pat_in)        $
+    tcHsSigType PatSigCtxt sig         `thenM` \ sig_ty ->
+    tcSubPat sig_ty pat_ty             `thenM` \ co_fn ->
+    tcPat tc_bndr pat (Check sig_ty)   `thenM` \ (pat', tvs, ids, lie_avail) ->
+    returnM (co_fn <$> unLoc pat', tvs, ids, lie_avail)
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Explicit lists and tuples}
+\subsection{Explicit lists, parallel arrays, and tuples}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-tcPat e pat_in@(ListPatIn pats)
-  = tcPats e pats      `thenTc`    \ (pats', lie, tys) ->
-    newPolyTyVarTy     `thenNF_Tc` \ tyvar_ty ->
-
-    unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_`
-
-    returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
+tc_pat tc_bndr pat_in@(ListPat pats _) pat_ty
+  = addErrCtxt (patCtxt pat_in)                $
+    zapToListTy pat_ty                         `thenM` \ elem_ty ->
+    tcPats tc_bndr pats (repeat elem_ty)       `thenM` \ (pats', tvs, ids, lie_avail) ->
+    returnM (ListPat pats' elem_ty, tvs, ids, lie_avail)
 
-tcPat e pat_in@(TuplePatIn pats)
-  = let
-       arity = length pats
-    in
-    tcPats e pats   `thenTc` \ (pats', lie, tys) ->
+tc_pat tc_bndr pat_in@(PArrPat pats _) pat_ty
+  = addErrCtxt (patCtxt pat_in)                $
+    zapToPArrTy pat_ty                         `thenM` \ elem_ty ->
+    tcPats tc_bndr pats (repeat elem_ty)       `thenM` \ (pats', tvs, ids, lie_avail) ->
+    returnM (PArrPat pats' elem_ty, tvs, ids, lie_avail)
 
-       -- We have to unify with fresh polymorphic type variables, to
-       -- make sure we record that the tuples can only contain boxed
-       -- types.
-    newPolyTyVarTys arity   `thenNF_Tc` \ tyvar_tys ->
+tc_pat tc_bndr pat_in@(TuplePat pats boxity) pat_ty
+  = addErrCtxt (patCtxt pat_in)        $
 
-    unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_`
+    zapToTupleTy boxity arity pat_ty           `thenM` \ arg_tys ->
+    tcPats tc_bndr pats arg_tys                `thenM` \ (pats', tvs, ids, lie_avail) ->
 
        -- possibly do the "make all tuple-pats irrefutable" test:
-    getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
     let
-       unmangled_result = TuplePat pats'
+       unmangled_result = TuplePat pats' boxity
 
        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
        -- so that we can experiment with lazy tuple-matching.
        -- This is a pretty odd place to make the switch, but
        -- it was easy to do.
-       possibly_mangled_result
-         = if sw_chkr IrrefutableTuples
-           then LazyPat unmangled_result
-           else unmangled_result
 
-       -- ToDo: IrrefutableEverything
+       possibly_mangled_result
+         | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result)
+         | otherwise                               = unmangled_result
     in
-    returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
+    returnM (possibly_mangled_result, tvs, ids, lie_avail)
+  where
+    arity = length pats
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection{Other constructors}
 %*                                                                     *
-%************************************************************************
 
-Constructor patterns are a little fun:
-\begin{itemize}
-\item
-typecheck the arguments
-\item
-look up the constructor
-\item
-specialise its type (ignore the translation this produces)
-\item
-check that the context produced by this specialisation is empty
-\item
-get the arguments out of the function type produced from specialising
-\item
-unify them with the types of the patterns
-\item
-back substitute with the type of the result of the constructor
-\end{itemize}
-
-ToDo: exploit new representation of constructors to make this more
-efficient?
+%************************************************************************
 
 \begin{code}
-tcPat e pat_in@(ConPatIn name pats)
-  = let
-       con_id = lookupE_Value e name
-    in
-    tcPats e pats `thenTc` \ (pats', lie, tys) ->
+tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty
+  = addErrCtxt (patCtxt pat_in)                        $
 
-    matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
+       -- Check that it's a constructor, and instantiate it
+    tcLookupLocatedDataCon con_name            `thenM` \ data_con ->
+    tcInstDataCon (PatOrigin pat_in) data_con  `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) ->
 
-    returnTc (ConPat con_id data_ty pats', lie, data_ty)
+       -- Check overall type matches.
+       -- The pat_ty might be a for-all type, in which
+       -- case we must instantiate to match
+    tcSubPat con_res_ty pat_ty                         `thenM` \ co_fn ->
 
-tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
-  = let
-       con_id = lookupE_Value e op
-    in
-    tcPats e [pat1, pat2]   `thenTc`   \ ([pat1',pat2'], lie, tys) ->
-        -- ToDo: there exists a less ugly way, no doubt...
-
-    matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
+       -- Check the argument patterns
+    tcConStuff tc_bndr data_con arg_pats arg_tys       `thenM` \ (arg_pats', arg_tvs, arg_ids, ex_dicts2) ->
 
-    returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty)
+    returnM (co_fn <$> ConPatOut data_con arg_pats' con_res_ty ex_tvs (map instToId ex_dicts1),
+             listToBag ex_tvs `unionBags` arg_tvs,
+             arg_ids,
+             ex_dicts1 ++ ex_dicts2)
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Non-overloaded literals}
+\subsection{Literals}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-tcPat e (LitPatIn lit@(CharLit str))
-  = returnTc (LitPat lit charTy, nullLIE, charTy)
+tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
+  = zapExpectedType pat_ty             `thenM` \ pat_ty' ->
+    unifyTauTy pat_ty' stringTy                `thenM_` 
+    tcLookupId eqStringName            `thenM` \ eq_id ->
+    returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), 
+           emptyBag, emptyBag, [])
+
+tc_pat tc_bndr (LitPat simple_lit) pat_ty
+  = zapExpectedType pat_ty                     `thenM` \ pat_ty' ->
+    unifyTauTy pat_ty' (hsLitType simple_lit)  `thenM_` 
+    returnM (LitPat simple_lit, emptyBag, emptyBag, [])
+
+tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
+  = zapExpectedType pat_ty                     `thenM` \ pat_ty' ->
+    newOverloadedLit origin over_lit pat_ty'   `thenM` \ pos_lit_expr ->
+    newMethodFromName origin pat_ty' eqName    `thenM` \ eq ->
+    (case mb_neg of
+       Nothing  -> returnM pos_lit_expr        -- Positive literal
+       Just neg ->     -- Negative literal
+                       -- The 'negate' is re-mappable syntax
+           tcSyntaxName origin pat_ty' (negateName, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) ->
+           returnM (mkHsApp neg_expr pos_lit_expr)
+    )                                                          `thenM` \ lit_expr ->
 
-tcPat e (LitPatIn lit@(StringLit str))
-  = getSrcLocTc                                `thenNF_Tc` \ loc ->
     let
-       origin = LiteralOrigin lit loc
-       eq_id  = lookupE_ClassOpByKey e eqClassKey  SLIT("==")
+       -- The literal in an NPatIn is always positive...
+       -- But in NPat, the literal is used to find identical patterns
+       --      so we must negate the literal when necessary!
+       lit' = case (over_lit, mb_neg) of
+                (HsIntegral i _,   Nothing) -> HsInteger i pat_ty'
+                (HsIntegral i _,   Just _)  -> HsInteger (-i) pat_ty'
+                (HsFractional f _, Nothing) -> HsRat f pat_ty'
+                (HsFractional f _, Just _)  -> HsRat (-f) pat_ty'
     in
-    newMethod origin eq_id [stringTy]  `thenNF_Tc` \ eq ->
-    let
-       comp_op = App (Var (mkInstId eq)) (Lit lit)
-    in
-    returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy)
-
-{- OLD:
-tcPat e (LitPatIn lit@(StringLit str))
-  = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy)
+    returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr),
+            emptyBag, emptyBag, [])
   where
-    comp_op   = App (Var eqStringId) (Lit lit)
--}
-
-tcPat e (LitPatIn lit@(IntPrimLit _))
-  = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy)
-tcPat e (LitPatIn lit@(CharPrimLit _))
-  = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy)
-tcPat e (LitPatIn lit@(StringPrimLit _))
-  = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy)
-tcPat e (LitPatIn lit@(FloatPrimLit _))
-  = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy)
-tcPat e (LitPatIn lit@(DoublePrimLit _))
-  = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy)
+    origin = PatOrigin pat
 \end{code}
 
 %************************************************************************
 %*                                                                     *
-\subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
+\subsection{n+k patterns}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-tcPat e (LitPatIn lit@(IntLit i))
-  = getSrcLocTc                                `thenNF_Tc` \ loc ->
-    let
-       origin = LiteralOrigin lit loc
-    in
-    newPolyTyVarTy                     `thenNF_Tc` \ tyvar_ty ->
-    let
-       from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
-       from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
-       eq_id        = lookupE_ClassOpByKey e eqClassKey  SLIT("==")
+tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty
+  = addSrcSpan nm_loc (tc_bndr name pat_ty)     `thenM` \ (co_fn, bndr_id) ->
+    let 
+       pat_ty' = idType bndr_id
     in
-    newOverloadedLit origin
-                    (OverloadedIntegral i from_int from_integer)
-                    tyvar_ty           `thenNF_Tc` \ over_lit ->
+    newOverloadedLit origin lit pat_ty'                 `thenM` \ over_lit_expr ->
+    newMethodFromName origin pat_ty' geName     `thenM` \ ge ->
+
+       -- The '-' part is re-mappable syntax
+    tcSyntaxName origin pat_ty' (minusName, noLoc (HsVar minus_name))  `thenM` \ (_, minus_expr) ->
+
+       -- The Report says that n+k patterns must be in Integral
+       -- We may not want this when using re-mappable syntax, though (ToDo?)
+    tcLookupClass integralClassName                    `thenM` \ icls ->
+    newDicts origin [mkClassPred icls [pat_ty']]       `thenM` \ dicts ->
+    extendLIEs dicts                                   `thenM_`
+    
+    returnM (NPlusKPatOut (L nm_loc bndr_id) i 
+                          (SectionR (nlHsVar ge) over_lit_expr)
+                          (SectionR minus_expr over_lit_expr),
+             emptyBag, unitBag (name, bndr_id), [])
+  where
+    origin = PatOrigin pat
+\end{code}
 
-    newMethod origin eq_id [tyvar_ty]  `thenNF_Tc` \ eq ->
 
-    returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
-                                    (Var (mkInstId over_lit))),
-             mkLIE [over_lit, eq],
-             tyvar_ty)
+%************************************************************************
+%*                                                                     *
+\subsection{Lists of patterns}
+%*                                                                     *
+%************************************************************************
 
-tcPat e (LitPatIn lit@(FracLit f))
-  = getSrcLocTc                                `thenNF_Tc` \ loc ->
-    let
-       origin = LiteralOrigin lit loc
-    in
-    newPolyTyVarTy                     `thenNF_Tc` \ tyvar_ty ->
-    let
-       eq_id         = lookupE_ClassOpByKey e eqClassKey         SLIT("==")
-       from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
-    in
-    newOverloadedLit origin
-                    (OverloadedFractional f from_rational)
-                    tyvar_ty           `thenNF_Tc` \ over_lit ->
+Helper functions
 
-    newMethod origin eq_id [tyvar_ty]  `thenNF_Tc` \ eq ->
+\begin{code}
+tcPats :: BinderChecker                        -- How to deal with variables
+       -> [LPat Name] -> [TcType]      -- Excess 'expected types' discarded
+       -> TcM ([LPat TcId], 
+                Bag TcTyVar,
+                Bag (Name, TcId),      -- Ids bound by the pattern
+                [Inst])                -- Dicts bound by the pattern
+
+tcPats tc_bndr [] tys = returnM ([], emptyBag, emptyBag, [])
+
+tcPats tc_bndr (pat:pats) (ty:tys)
+  = tcPat tc_bndr pat (Check ty)       `thenM` \ (pat',  tvs1, ids1, lie_avail1) ->
+    tcPats tc_bndr pats tys            `thenM` \ (pats', tvs2, ids2, lie_avail2) ->
+
+    returnM (pat':pats', 
+             tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, 
+             lie_avail1 ++ lie_avail2)
+\end{code}
 
-    returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
-                                    (Var (mkInstId over_lit))),
-             mkLIE [over_lit, eq],
-             tyvar_ty)
 
-tcPat e (LitPatIn lit@(LitLitLitIn s))
-  = error "tcPat: can't handle ``literal-literal'' patterns"
-{-
-  = getSrcLocTc                                `thenNF_Tc` \ loc ->
-    let
-       origin = LiteralOrigin lit loc
-    in
-    newPolyTyVarTy                     `thenNF_Tc` \ tyvar_ty ->
-    let
-       eq_id = lookupE_ClassOpByKey e eqClassKey "=="
-    in
-    newOverloadedLit origin
-                    (OverloadedLitLit s)
-                    tyvar_ty           `thenNF_Tc` \ over_lit ->
+%************************************************************************
+%*                                                                     *
+\subsection{Constructor arguments}
+%*                                                                     *
+%************************************************************************
 
-    newMethod origin eq_id [tyvar_ty]  `thenNF_Tc` \ eq ->
+\begin{code}
+tcConStuff tc_bndr data_con (PrefixCon arg_pats) arg_tys
+  =    -- Check correct arity
+    checkTc (con_arity == no_of_args)
+           (arityErr "Constructor" data_con con_arity no_of_args)      `thenM_`
 
-    returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
-                                    (Var (mkInstId over_lit))),
-             mkLIE [over_lit, eq],
-             tyvar_ty)
--}
+       -- Check arguments
+    tcPats tc_bndr arg_pats arg_tys    `thenM` \ (arg_pats', tvs, ids, lie_avail) ->
 
-tcPat e (NPlusKPatIn name lit@(IntLit k))
-  = getSrcLocTc                                `thenNF_Tc` \ loc ->
-    let
-       origin   = LiteralOrigin lit loc
+    returnM (PrefixCon arg_pats', tvs, ids, lie_avail)
+  where
+    con_arity  = dataConSourceArity data_con
+    no_of_args = length arg_pats
 
-       local    = lookupE_Binder e name
-       local_ty = getIdUniType local
+tcConStuff tc_bndr data_con (InfixCon p1 p2) arg_tys
+  =    -- Check correct arity
+    checkTc (con_arity == 2)
+           (arityErr "Constructor" data_con con_arity 2)       `thenM_`
 
-       ge_id        = lookupE_ClassOpByKey e ordClassKey SLIT(">=")
-       minus_id     = lookupE_ClassOpByKey e numClassKey SLIT("-")
-       from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
-       from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
-    in
-    newOverloadedLit origin
-                    (OverloadedIntegral k from_int from_integer)
-                    local_ty              `thenNF_Tc` \ over_lit ->
-
-    newMethod origin ge_id     [local_ty] `thenNF_Tc` \ ge ->
-    newMethod origin minus_id  [local_ty] `thenNF_Tc` \ minus ->
-
-    returnTc (NPlusKPat local lit local_ty
-                       (Var (mkInstId over_lit))
-                       (Var (mkInstId ge))
-                       (Var (mkInstId minus)),
-             mkLIE [over_lit, ge, minus],
-             local_ty)
-
-tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit"
-
-#ifdef DPH
-tcPat e (ProcessorPatIn pats pat)
-  = tcPidPats e pats           `thenTc` \ (pats',convs, lie, tys)->
-    tcPat e pat                `thenTc` \ (pat', ty, lie') ->
-    returnTc (ProcessorPat pats' convs pat',
-             plusLIE lie lie',
-             mkProcessorTy tys ty)
-#endif {- Data Parallel Haskell -}
+       -- Check arguments
+    tcPat tc_bndr p1 (Check ty1)       `thenM` \ (p1', tvs1, ids1, lie_avail1) ->
+    tcPat tc_bndr p2 (Check ty2)       `thenM` \ (p2', tvs2, ids2, lie_avail2) ->
+
+    returnM (InfixCon p1' p2', 
+             tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, 
+             lie_avail1 ++ lie_avail2)
+  where
+    con_arity  = dataConSourceArity data_con
+    [ty1, ty2] = arg_tys
+
+tcConStuff tc_bndr data_con (RecCon rpats) arg_tys
+  =    -- Check the fields
+    tc_fields field_tys rpats  `thenM` \ (rpats', tvs, ids, lie_avail) ->
+    returnM (RecCon rpats', tvs, ids, lie_avail)
+
+  where
+    field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) arg_tys
+       -- Don't use zipEqual! If the constructor isn't really a record, then
+       -- dataConFieldLabels will be empty (and each field in the pattern
+       -- will generate an error below).
+
+    tc_fields field_tys []
+      = returnM ([], emptyBag, emptyBag, [])
+
+    tc_fields field_tys ((L lbl_loc field_label, rhs_pat) : rpats)
+      =        tc_fields field_tys rpats       `thenM` \ (rpats', tvs1, ids1, lie_avail1) ->
+
+       (case [ty | (f,ty) <- field_tys, f == field_label] of
+
+               -- No matching field; chances are this field label comes from some
+               -- other record type (or maybe none).  As well as reporting an
+               -- error we still want to typecheck the pattern, principally to
+               -- make sure that all the variables it binds are put into the
+               -- environment, else the type checker crashes later:
+               --      f (R { foo = (a,b) }) = a+b
+               -- If foo isn't one of R's fields, we don't want to crash when
+               -- typechecking the "a+b".
+          [] -> addErrTc (badFieldCon data_con field_label)    `thenM_` 
+                newTyVarTy liftedTypeKind                      `thenM` \ bogus_ty ->
+                returnM (error "Bogus selector Id", bogus_ty)
+
+               -- The normal case, when the field comes from the right constructor
+          (pat_ty : extras) -> 
+               ASSERT( null extras )
+               addSrcSpan lbl_loc (tcLookupId field_label)     `thenM` \ sel_id ->
+               returnM (sel_id, pat_ty)
+       )                                               `thenM` \ (sel_id, pat_ty) ->
+
+       tcPat tc_bndr rhs_pat (Check pat_ty)    `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) ->
+
+       returnM ((L lbl_loc sel_id, rhs_pat') : rpats',
+                 tvs1 `unionBags` tvs2,
+                 ids1 `unionBags` ids2,
+                 lie_avail1 ++ lie_avail2)
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Lists of patterns}
+\subsection{Subsumption}
 %*                                                                     *
 %************************************************************************
 
+Example:  
+       f :: (forall a. a->a) -> Int -> Int
+       f (g::Int->Int) y = g y
+This is ok: the type signature allows fewer callers than
+the (more general) signature f :: (Int->Int) -> Int -> Int
+I.e.    (forall a. a->a) <= Int -> Int
+We end up translating this to:
+       f = \g' :: (forall a. a->a).  let g = g' Int in g' y
+
+tcSubPat does the work
+       sig_ty is the signature on the pattern itself 
+               (Int->Int in the example)
+       expected_ty is the type passed inwards from the context
+               (forall a. a->a in the example)
+
 \begin{code}
-tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType])
+tcSubPat :: TcSigmaType -> Expected TcSigmaType -> TcM PatCoFn
+
+tcSubPat sig_ty exp_ty
+ = tcSubOff sig_ty exp_ty              `thenM` \ co_fn ->
+       -- co_fn is a coercion on *expressions*, and we
+       -- need to make a coercion on *patterns*
+   if isIdCoercion co_fn then
+       returnM idCoercion
+   else
+   newUnique                           `thenM` \ uniq ->
+   readExpectedType exp_ty             `thenM` \ exp_ty' ->
+   let
+       arg_id  = mkSysLocal FSLIT("sub") uniq exp_ty'
+       the_fn  = DictLam [arg_id] (noLoc (co_fn <$> HsVar arg_id))
+       pat_co_fn p = SigPatOut (noLoc p) exp_ty' the_fn
+   in
+   returnM (mkCoercion pat_co_fn)
+\end{code}
 
-tcPats e [] = returnTc ([], nullLIE, [])
 
-tcPats e (pat:pats)
-  = tcPat e pat                        `thenTc` \ (pat',  lie,  ty)  ->
-    tcPats e pats              `thenTc` \ (pats', lie', tys) ->
+%************************************************************************
+%*                                                                     *
+\subsection{Errors and contexts}
+%*                                                                     *
+%************************************************************************
 
-    returnTc (pat':pats', plusLIE lie lie', ty:tys)
-\end{code}
+\begin{code}
+patCtxt pat = hang (ptext SLIT("When checking the pattern:")) 
+                4 (ppr pat)
 
-@matchConArgTys@ grabs the signature of the data constructor, and
-unifies the actual args against the expected ones.
+badFieldCon :: DataCon -> Name -> SDoc
+badFieldCon con field
+  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
+         ptext SLIT("does not have field"), quotes (ppr field)]
 
-\begin{code}
-matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType
-
-matchConArgTys con_id arg_tys err_ctxt
-  = let
-       no_of_args = length arg_tys
-       (sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id
-            -- Ignore the sig_theta; overloaded constructors only
-            -- behave differently when called, not when used for
-            -- matching.
-       con_arity  = length sig_tys
-    in
-    getSrcLocTc                                `thenNF_Tc` \ loc ->
-    checkTc (con_arity /= no_of_args) 
-           (dataConArityErr con_id con_arity no_of_args loc) `thenTc_`
+polyPatSig :: TcType -> SDoc
+polyPatSig sig_ty
+  = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
+        4 (ppr sig_ty)
 
-    copyTyVars sig_tyvars              `thenNF_Tc` \ (inst_env, _, new_tyvar_tys) ->
-    let 
-       (_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys
-    in
-    unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty)  `thenTc_`
-    returnTc inst_result_ty
+badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
 \end{code}
+