projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[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
dfd92d1
..
becc2d6
100644
(file)
--- a/
ghc/compiler/typecheck/TcPat.lhs
+++ b/
ghc/compiler/typecheck/TcPat.lhs
@@
-8,22
+8,23
@@
module TcPat ( tcPat ) where
module TcPat ( tcPat ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Match, HsBinds, Qual, PolyType,
+ Match, HsBinds, Qualifier, PolyType,
ArithSeqInfo, Stmt, Fake )
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(..),
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
- emptyLIE, plusLIE, plusLIEs, LIE(..),
+ emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
newMethod, newOverloadedLit
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
newMethod, newOverloadedLit
)
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcLookupLocalValueOK, tcGlobalOcc )
-import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
+ tcLookupLocalValueOK )
+import SpecEnv ( SpecEnv )
+import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
import Bag ( Bag )
@@
-31,19
+32,20
@@
import CmdLineOpts ( opt_IrrefutableTuples )
import Id ( GenId, idType )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import Maybes ( maybeToBool )
import Id ( GenId, idType )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import Maybes ( maybeToBool )
-import Name ( Name )
import PprType ( GenType, GenTyVar )
import PprType ( GenType, GenTyVar )
-import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, charTy, stringTy, mkListTy,
- mkTupleTy, addrTy, addrPrimTy )
+--import PprStyle--ToDo:rm
import Pretty
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
import Pretty
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
- Type(..), GenType
+ SYN_IE(Type), GenType
)
import TyVar ( GenTyVar )
)
import TyVar ( GenTyVar )
+import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
+ doublePrimTy, addrPrimTy
+ )
+import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
import Unique ( Unique, eqClassOpKey )
import Unique ( Unique, eqClassOpKey )
-import Util ( assertPanic, panic{-ToDo:rm-} )
+import Util ( assertPanic, panic )
\end{code}
\begin{code}
\end{code}
\begin{code}
@@
-58,7
+60,7
@@
tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
\begin{code}
tcPat (VarPatIn name)
\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)
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)
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)
= 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}
%************************************************************************
\end{code}
%************************************************************************
@@
-161,7
+173,7
@@
tcPat pat_in@(ConPatIn name pats)
lie,
data_ty)
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) ->
= tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
@@
-181,26
+193,27
@@
tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
\begin{code}
tcPat pat_in@(RecPatIn name rpats)
\begin{code}
tcPat pat_in@(RecPatIn name rpats)
- = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) ->
+ = tcLookupGlobalValue name `thenNF_Tc` \ con_id ->
+ tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
let
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
-- 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 ) )
+ ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
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,
plusLIEs lies,
- record_ty-})
+ record_ty)
where
do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
where
do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
- = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
+ = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
+ tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
-- Record selectors all have type
-- forall a1..an. T a1 .. an -> tau
-- Record selectors all have type
-- forall a1..an. T a1 .. an -> tau
@@
-313,16
+326,15
@@
tcPats (pat:pats)
unifies the actual args against the expected ones.
\begin{code}
unifies the actual args against the expected ones.
\begin{code}
-matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
+matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
matchConArgTys con arg_tys
matchConArgTys con arg_tys
- = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) ->
- let
- (con_theta, con_tau) = splitRhoTy con_rho
+ = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
+ tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) ->
-- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
-- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
-
+ let
(con_args, con_result) = splitFunTy con_tau
con_arity = length con_args
no_of_args = length arg_tys
(con_args, con_result) = splitFunTy con_tau
con_arity = length con_args
no_of_args = length arg_tys
@@
-330,7
+342,7
@@
matchConArgTys con arg_tys
checkTc (con_arity == no_of_args)
(arityErr "Constructor" con_id con_arity no_of_args) `thenTc_`
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}
returnTc (con_id, con_result)
\end{code}