\section[TcPat]{Typechecking patterns}
\begin{code}
-#include "HsVersions.h"
-
module TcPat ( tcPat ) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Match, HsBinds, Qualifier, HsType,
- ArithSeqInfo, Stmt, Fake )
-import RnHsSyn ( SYN_IE(RenamedPat) )
-import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) )
+import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) )
+import RnHsSyn ( RenamedPat )
+import TcHsSyn ( TcPat )
import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
- emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
+ emptyLIE, plusLIE, plusLIEs, LIE,
newMethod, newOverloadedLit
)
import Name ( Name {- instance Outputable -} )
-import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
- tcLookupLocalValueOK )
-import SpecEnv ( SpecEnv )
-import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
+import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey,
+ tcLookupLocalValueOK, tcInstId
+ )
+import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
+import Maybes ( maybeToBool )
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
-import Id ( GenId, idType )
+import Id ( GenId, idType, Id )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-import Maybes ( maybeToBool )
-import PprType ( GenType, GenTyVar )
---import PprStyle--ToDo:rm
-import Pretty
-import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
- getFunTy_maybe, maybeAppDataTyCon,
- SYN_IE(Type), GenType
+import Type ( splitFunTys, splitRhoTy,
+ splitFunTy_maybe, splitAlgTyConApp_maybe,
+ Type
)
-import TyVar ( GenTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
-import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
-import Unique ( Unique, eqClassOpKey )
+import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy )
+import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
import Util ( assertPanic, panic )
+import Outputable
\end{code}
\begin{code}
\begin{code}
tcPat (VarPatIn name)
- = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name `thenNF_Tc` \ id ->
+ = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
returnTc (VarPat (TcId id), emptyLIE, idType id)
tcPat (LazyPatIn pat)
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) ->
-- Ignore the con_theta; overloaded constructors only
-- behave differently when called, not when used for
-- matching.
- (_, record_ty) = splitFunTy con_tau
+ (_, record_ty) = splitFunTys con_tau
in
-- Con is syntactically constrained to be a data constructor
- ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
+ ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
-- Record selectors all have type
-- forall a1..an. T a1 .. an -> tau
- ASSERT( maybeToBool (getFunTy_maybe tau) )
+ ASSERT( maybeToBool (splitFunTy_maybe tau) )
let
-- Selector must have type RecordType -> FieldType
- Just (record_ty, field_ty) = getFunTy_maybe tau
+ Just (record_ty, field_ty) = splitFunTy_maybe tau
in
tcAddErrCtxt (recordLabel field_label) (
unifyTauTy expected_record_ty record_ty
tcPat (LitPatIn lit@(HsInt i))
= newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
newOverloadedLit origin
- (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
+ (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
- (HsVar over_lit_id)),
+ over_lit_expr),
lie1 `plusLIE` lie2,
tyvar_ty)
where
tcPat (LitPatIn lit@(HsFrac f))
= newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
newOverloadedLit origin
- (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) ->
+ (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) ->
returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
- (HsVar over_lit_id)),
+ over_lit_expr),
lie1 `plusLIE` lie2,
tyvar_ty)
where
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` \ (over_lit_expr, lie1) ->
+
+ 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) over_lit_expr)
+ (SectionR (HsVar minus_id) over_lit_expr),
+ 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}
%************************************************************************
-- behave differently when called, not when used for
-- matching.
let
- (con_args, con_result) = splitFunTy con_tau
+ (con_args, con_result) = splitFunTys con_tau
con_arity = length con_args
no_of_args = length arg_tys
in
Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
-patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
+patCtxt pat = hang (ptext SLIT("In the pattern:"))
+ 4 (ppr pat)
-recordLabel field_label sty
- = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
- 4 (ppBesides [ppStr "with its immediately enclosing constructor"])
+recordLabel field_label
+ = hang (hcat [ptext SLIT("When matching record field"), ppr 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])
+recordRhs field_label pat
+ = hang (ptext SLIT("In the record field pattern"))
+ 4 (sep [ppr field_label, char '=', ppr pat])
\end{code}
projects / ghc-hetmet.git / blobdiff