[project @ 1998-06-26 12:01:24 by sof]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcPat.lhs

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index e1155b0..edb4cc5 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -4,7 +4,7 @@
 \section[TcPat]{Typechecking patterns}
 
 \begin{code}
-module TcPat ( tcPat ) where
+module TcPat ( tcPat, badFieldsCon ) where
 
 #include "HsVersions.h"
 
@@ -22,12 +22,13 @@ import TcEnv                ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey,
                          tcLookupLocalValueOK, tcInstId
                        )
 import TcType          ( TcType, TcMaybe, newTyVarTy, newTyVarTys )
+import FieldLabel      ( fieldLabelName )
 import Unify           ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Maybes          ( maybeToBool )
 import Bag             ( Bag )
 import CmdLineOpts     ( opt_IrrefutableTuples )
-import Id              ( GenId, idType, Id )
+import Id              ( GenId, idType, Id, dataConFieldLabels )
 import Kind            ( Kind, mkBoxedTypeKind, mkTypeKind )
 import Type            ( splitFunTys, splitRhoTy,
                          splitFunTy_maybe, splitAlgTyConApp_maybe,
@@ -36,7 +37,7 @@ import Type           ( splitFunTys, splitRhoTy,
 import TysPrim         ( charPrimTy, intPrimTy, floatPrimTy,
                          doublePrimTy, addrPrimTy
                        )
-import TysWiredIn      ( charTy, stringTy, mkListTy, mkTupleTy )
+import TysWiredIn      ( charTy, stringTy, mkListTy, mkTupleTy, intTy )
 import Unique          ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
 import Util            ( assertPanic, panic )
 import Outputable
@@ -194,7 +195,13 @@ tcPat pat_in@(RecPatIn name rpats)
             -- behave differently when called, not when used for
             -- matching.
        (_, record_ty) = splitFunTys con_tau
+
+       field_names = map fieldLabelName (dataConFieldLabels con_id)
+       bad_fields  = [f | (f,_,_) <- rpats, not (f `elem` field_names)]
     in
+       -- Check that all the fields are from this constructor
+    checkTc (null bad_fields) (badFieldsCon name bad_fields)   `thenTc_`
+    
        -- Con is syntactically constrained to be a data constructor
     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
 
@@ -295,7 +302,8 @@ tcPat (LitPatIn lit@(HsFrac f))
     origin = LiteralOrigin lit
 
 tcPat (LitPatIn lit@(HsLitLit s))
-  = error "tcPat: can't handle ``literal-literal'' patterns"
+--  = error "tcPat: can't handle ``literal-literal'' patterns"
+  = returnTc (LitPat lit intTy, emptyLIE, intTy)
 
 tcPat (NPlusKPatIn name lit@(HsInt i))
   = tcLookupLocalValueOK "tcPat1:n+k" name     `thenNF_Tc` \ local ->
@@ -364,7 +372,6 @@ matchConArgTys con arg_tys
     returnTc (con_id, con_result)
 \end{code}
 
-
 % =================================================
 
 Errors and contexts
@@ -380,4 +387,10 @@ recordLabel field_label
 recordRhs field_label pat
   = hang (ptext SLIT("In the record field pattern"))
         4 (sep [ppr field_label, char '=', ppr pat])
+
+badFieldsCon :: Name -> [Name] -> SDoc
+badFieldsCon con fields
+  = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
+         ptext SLIT("does not have field(s):"), pprQuotedList fields]
 \end{code}
+