[project @ 1997-06-05 09:16:04 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 b857bb0..4b2241c 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -11,41 +11,45 @@ module TcPat ( tcPat ) where
 IMP_Ubiq(){-uitous-}
 
 import HsSyn           ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
-                         Match, HsBinds, Qual, PolyType,
-                         ArithSeqInfo, Stmt, Fake )
-import RnHsSyn         ( RenamedPat(..) )
-import TcHsSyn         ( TcPat(..), TcIdOcc(..) )
+                         Match, HsBinds, HsType, Fixity,
+                         ArithSeqInfo, Stmt, DoOrListComp, Fake )
+import RnHsSyn         ( SYN_IE(RenamedPat) )
+import TcHsSyn         ( SYN_IE(TcPat), TcIdOcc(..) )
 
-import TcMonad         hiding ( rnMtoTcM )
+import TcMonad
 import Inst            ( Inst, OverloadedLit(..), InstOrigin(..),
-                         emptyLIE, plusLIE, plusLIEs, LIE(..),
+                         emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
                          newMethod, newOverloadedLit
                        )
+import Name            ( Name {- instance Outputable -} )
 import TcEnv           ( tcLookupGlobalValue, tcLookupGlobalValueByKey, 
                          tcLookupLocalValueOK )
-import TcType          ( TcType(..), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
+import SpecEnv         ( SpecEnv )
+import TcType          ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
 import Unify           ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
 
 import Bag             ( Bag )
 import CmdLineOpts     ( opt_IrrefutableTuples )
-import Id              ( GenId, idType )
+import Id              ( GenId, idType, SYN_IE(Id) )
 import Kind            ( Kind, mkBoxedTypeKind, mkTypeKind )
 import Maybes          ( maybeToBool )
 import PprType         ( GenType, GenTyVar )
-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 Unique          ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
+import Util            ( assertPanic, panic )
+
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
 \end{code}
 
 \begin{code}
@@ -60,7 +64,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
 
 \begin{code}
 tcPat (VarPatIn name)
-  = tcLookupLocalValueOK ("tcPat1:"++ppShow 80 (ppr PprDebug name)) name       `thenNF_Tc` \ id ->
+  = tcLookupLocalValueOK ("tcPat1:"{-++show (ppr PprDebug name)-}) name        `thenNF_Tc` \ id ->
     returnTc (VarPat (TcId id), emptyLIE, idType id)
 
 tcPat (LazyPatIn pat)
@@ -173,7 +177,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) ->
 
@@ -302,6 +306,30 @@ tcPat (LitPatIn lit@(HsFrac f))
 
 tcPat (LitPatIn lit@(HsLitLit s))
   = error "tcPat: can't handle ``literal-literal'' patterns"
+
+tcPat (NPlusKPatIn name lit@(HsInt i))
+  = tcLookupLocalValueOK "tcPat1:n+k" name     `thenNF_Tc` \ local ->
+    let
+       local_ty = idType local
+    in
+    tcLookupGlobalValueByKey geClassOpKey              `thenNF_Tc` \ ge_sel_id ->
+    tcLookupGlobalValueByKey minusClassOpKey           `thenNF_Tc` \ minus_sel_id ->
+
+    newOverloadedLit origin
+                    (OverloadedIntegral i) local_ty    `thenNF_Tc` \ (lie1, over_lit_id) ->
+
+    newMethod origin (RealId ge_sel_id)    [local_ty]  `thenNF_Tc` \ (lie2, ge_id) ->
+    newMethod origin (RealId minus_sel_id) [local_ty]  `thenNF_Tc` \ (lie3, minus_id) ->
+
+    returnTc (NPlusKPat (TcId local) lit local_ty
+                       (SectionR (HsVar ge_id) (HsVar over_lit_id))
+                       (SectionR (HsVar minus_id) (HsVar over_lit_id)),
+             lie1 `plusLIE` lie2 `plusLIE` lie3,
+             local_ty)
+  where
+    origin = LiteralOrigin lit -- Not very good!
+
+tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
 \end{code}
 
 %************************************************************************
@@ -326,7 +354,7 @@ tcPats (pat:pats)
 unifies the actual args against the expected ones.
 
 \begin{code}
-matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
+matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
 
 matchConArgTys con arg_tys
   = tcLookupGlobalValue con            `thenNF_Tc` \ con_id ->
@@ -342,7 +370,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}
 
@@ -352,13 +380,13 @@ matchConArgTys con arg_tys
 Errors and contexts
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
-patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
+patCtxt pat sty = hang (ptext SLIT("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"])
+  = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label])
+        4 (hcat [ptext SLIT("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])
+  = hang (ptext SLIT("In the record field pattern"))
+        4 (sep [ppr sty field_label, char '=', ppr sty pat])
 \end{code}