IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Match, HsBinds, Qualifier, PolyType,
- ArithSeqInfo, Stmt, Fake )
-import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+ 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, SYN_IE(LIE),
newMethod, newOverloadedLit
)
+import Name ( Name {- instance Outputable -} )
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
import SpecEnv ( SpecEnv )
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 Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
doublePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
-import Unique ( Unique, eqClassOpKey )
+import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey )
import Util ( assertPanic, panic )
+
+#if __GLASGOW_HASKELL__ >= 202
+import Outputable
+#endif
\end{code}
\begin{code}
\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)
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 (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}
%************************************************************************
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 ->
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}