[project @ 1996-07-19 18:36:04 by partain]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 16b0ca2..becc2d6 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -8,22 +8,23 @@
 
 module TcPat ( tcPat ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import HsSyn           ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
-                         Match, HsBinds, Qual, PolyType,
+                         Match, HsBinds, Qualifier, PolyType,
                          ArithSeqInfo, Stmt, Fake )
-import RnHsSyn         ( RenamedPat(..) )
-import TcHsSyn         ( TcPat(..), TcIdOcc(..) )
+import RnHsSyn         ( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+import TcHsSyn         ( SYN_IE(TcPat), TcIdOcc(..) )
 
-import TcMonad
+import TcMonad         hiding ( rnMtoTcM )
 import Inst            ( Inst, OverloadedLit(..), InstOrigin(..),
-                         emptyLIE, plusLIE, plusLIEs, LIE(..),
+                         emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
                          newMethod, newOverloadedLit
                        )
 import TcEnv           ( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
                          tcLookupLocalValueOK )
-import TcType          ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId )
+import SpecEnv         ( SpecEnv )
+import TcType          ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
 import Unify           ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Bag             ( Bag )
@@ -32,18 +33,19 @@ import Id           ( GenId, idType )
 import Kind            ( Kind, mkBoxedTypeKind, mkTypeKind )
 import Maybes          ( maybeToBool )
 import PprType         ( GenType, GenTyVar )
-import PrelInfo                ( charPrimTy, intPrimTy, floatPrimTy,
-                         doublePrimTy, charTy, stringTy, mkListTy,
-                         mkTupleTy, addrTy, addrPrimTy )
+--import PprStyle--ToDo:rm
 import Pretty
-import RnHsSyn         ( RnName{-instance Outputable-} )
 import Type            ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
                          getFunTy_maybe, maybeAppDataTyCon,
-                         Type(..), GenType
+                         SYN_IE(Type), GenType
                        )
 import TyVar           ( GenTyVar )
+import TysPrim         ( charPrimTy, intPrimTy, floatPrimTy,
+                         doublePrimTy, addrPrimTy
+                       )
+import TysWiredIn      ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
 import Unique          ( Unique, eqClassOpKey )
-import Util            ( assertPanic, panic{-ToDo:rm-} )
+import Util            ( assertPanic, panic )
 \end{code}
 
 \begin{code}
@@ -58,7 +60,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
 
 \begin{code}
 tcPat (VarPatIn name)
-  = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id ->
+  = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name   `thenNF_Tc` \ id ->
     returnTc (VarPat (TcId id), emptyLIE, idType id)
 
 tcPat (LazyPatIn pat)
@@ -72,9 +74,19 @@ tcPat pat_in@(AsPatIn name pat)
     unifyTauTy (idType id) ty          `thenTc_`
     returnTc (AsPat (TcId id) pat', lie, ty)
 
-tcPat (WildPatIn)
+tcPat WildPatIn
   = newTyVarTy mkTypeKind      `thenNF_Tc` \ tyvar_ty ->
     returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
+
+tcPat (NegPatIn pat)
+  = tcPat (negate_lit pat)
+  where
+    negate_lit (LitPatIn (HsInt  i)) = LitPatIn (HsInt  (-i))
+    negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
+    negate_lit _                     = panic "TcPat:negate_pat"
+
+tcPat (ParPatIn parend_pat)
+  = tcPat parend_pat
 \end{code}
 
 %************************************************************************
@@ -161,7 +173,7 @@ tcPat pat_in@(ConPatIn name pats)
              lie, 
              data_ty)
 
-tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
+tcPat pat_in@(ConOpPatIn pat1 op pat2)         -- in binary-op form...
   = tcPat pat1                         `thenTc` \ (pat1', lie1, ty1) ->
     tcPat pat2                         `thenTc` \ (pat2', lie2, ty2) ->
 
@@ -190,13 +202,13 @@ tcPat pat_in@(RecPatIn name rpats)
        (_, record_ty) = splitFunTy con_tau
     in
        -- Con is syntactically constrained to be a data constructor
-    ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
+    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', 
+    returnTc (RecPat con_id record_ty rpats', 
              plusLIEs lies, 
-             record_ty-})
+             record_ty)
 
   where
     do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
@@ -330,7 +342,7 @@ matchConArgTys con arg_tys
     checkTc (con_arity == no_of_args)
            (arityErr "Constructor" con_id con_arity no_of_args)        `thenTc_`
 
-    unifyTauTyLists arg_tys con_args                                   `thenTc_`
+    unifyTauTyLists con_args arg_tys                                   `thenTc_`
     returnTc (con_id, con_result)
 \end{code}