ghc/compiler/typecheck/TcPat.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcPat]{Typechecking patterns}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcPat ( tcPat ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12
  13 import HsSyn            ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  14                           Match, HsBinds, Qualifier, PolyType,
  15                           ArithSeqInfo, Stmt, Fake )
  16 import RnHsSyn          ( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
  17 import TcHsSyn          ( SYN_IE(TcPat), TcIdOcc(..) )
  18
  19 import TcMonad          hiding ( rnMtoTcM )
  20 import Inst             ( Inst, OverloadedLit(..), InstOrigin(..),
  21                           emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
  22                           newMethod, newOverloadedLit
  23                         )
  24 import TcEnv            ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
  25                           tcLookupLocalValueOK )
  26 import TcType           ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId )
  27 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
  28
  29 import Bag              ( Bag )
  30 import CmdLineOpts      ( opt_IrrefutableTuples )
  31 import Id               ( GenId, idType )
  32 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind )
  33 import Maybes           ( maybeToBool )
  34 import PprType          ( GenType, GenTyVar )
  35 import PprStyle--ToDo:rm
  36 import Pretty
  37 import Type             ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
  38                           getFunTy_maybe, maybeAppDataTyCon,
  39                           SYN_IE(Type), GenType
  40                         )
  41 import TyVar            ( GenTyVar )
  42 import TysPrim          ( charPrimTy, intPrimTy, floatPrimTy,
  43                           doublePrimTy, addrPrimTy
  44                         )
  45 import TysWiredIn       ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
  46 import Unique           ( Unique, eqClassOpKey )
  47 import Util             ( assertPanic, panic{-ToDo:rm-} )
  48 \end{code}
  49
  50 \begin{code}
  51 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
  52 \end{code}
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Variables, wildcards, lazy pats, as-pats}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 tcPat (VarPatIn name)
  62   = tcLookupLocalValueOK ("tcPat1:"++ppShow 80 (ppr PprDebug name)) name        `thenNF_Tc` \ id ->
  63     returnTc (VarPat (TcId id), emptyLIE, idType id)
  64
  65 tcPat (LazyPatIn pat)
  66   = tcPat pat           `thenTc` \ (pat', lie, ty) ->
  67     returnTc (LazyPat pat', lie, ty)
  68
  69 tcPat pat_in@(AsPatIn name pat)
  70   = tcLookupLocalValueOK "tcPat2"  name `thenNF_Tc` \ id ->
  71     tcPat pat                           `thenTc` \ (pat', lie, ty) ->
  72     tcAddErrCtxt (patCtxt pat_in)       $
  73     unifyTauTy (idType id) ty           `thenTc_`
  74     returnTc (AsPat (TcId id) pat', lie, ty)
  75
  76 tcPat WildPatIn
  77   = newTyVarTy mkTypeKind       `thenNF_Tc` \ tyvar_ty ->
  78     returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
  79
  80 tcPat (NegPatIn pat)
  81   = tcPat (negate_lit pat)
  82   where
  83     negate_lit (LitPatIn (HsInt  i)) = LitPatIn (HsInt  (-i))
  84     negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
  85     negate_lit _                     = panic "TcPat:negate_pat"
  86
  87 tcPat (ParPatIn parend_pat)
  88   = tcPat parend_pat
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection{Explicit lists and tuples}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 tcPat pat_in@(ListPatIn pats)
  99   = tcPats pats                         `thenTc`    \ (pats', lie, tys) ->
 100     newTyVarTy mkBoxedTypeKind          `thenNF_Tc` \ tyvar_ty ->
 101     tcAddErrCtxt (patCtxt pat_in)       $
 102     unifyTauTyList (tyvar_ty:tys)       `thenTc_`
 103
 104     returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
 105
 106 tcPat pat_in@(TuplePatIn pats)
 107   = let
 108         arity = length pats
 109     in
 110     tcPats pats                         `thenTc` \ (pats', lie, tys) ->
 111
 112         -- Make sure we record that the tuples can only contain boxed types
 113     newTyVarTys arity mkBoxedTypeKind   `thenNF_Tc` \ tyvar_tys ->
 114
 115     tcAddErrCtxt (patCtxt pat_in)       $
 116     unifyTauTyLists tyvar_tys tys       `thenTc_`
 117
 118         -- possibly do the "make all tuple-pats irrefutable" test:
 119     let
 120         unmangled_result = TuplePat pats'
 121
 122         -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 123         -- so that we can experiment with lazy tuple-matching.
 124         -- This is a pretty odd place to make the switch, but
 125         -- it was easy to do.
 126
 127         possibly_mangled_result
 128           = if opt_IrrefutableTuples
 129             then LazyPat unmangled_result
 130             else unmangled_result
 131
 132         -- ToDo: IrrefutableEverything
 133     in
 134     returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsection{Other constructors}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 Constructor patterns are a little fun:
 144 \begin{itemize}
 145 \item
 146 typecheck the arguments
 147 \item
 148 look up the constructor
 149 \item
 150 specialise its type (ignore the translation this produces)
 151 \item
 152 check that the context produced by this specialisation is empty
 153 \item
 154 get the arguments out of the function type produced from specialising
 155 \item
 156 unify them with the types of the patterns
 157 \item
 158 back substitute with the type of the result of the constructor
 159 \end{itemize}
 160
 161 ToDo: exploit new representation of constructors to make this more
 162 efficient?
 163
 164 \begin{code}
 165 tcPat pat_in@(ConPatIn name pats)
 166   = tcPats pats                         `thenTc` \ (pats', lie, tys) ->
 167
 168     tcAddErrCtxt (patCtxt pat_in)       $
 169     matchConArgTys name tys             `thenTc` \ (con_id, data_ty) ->
 170
 171     returnTc (ConPat con_id data_ty pats',
 172               lie,
 173               data_ty)
 174
 175 tcPat pat_in@(ConOpPatIn pat1 op pat2)  -- in binary-op form...
 176   = tcPat pat1                          `thenTc` \ (pat1', lie1, ty1) ->
 177     tcPat pat2                          `thenTc` \ (pat2', lie2, ty2) ->
 178
 179     tcAddErrCtxt (patCtxt pat_in)       $
 180     matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) ->
 181
 182     returnTc (ConOpPat pat1' con_id pat2' data_ty,
 183               lie1 `plusLIE` lie2,
 184               data_ty)
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection{Records}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 \begin{code}
 194 tcPat pat_in@(RecPatIn name rpats)
 195   = tcLookupGlobalValue name            `thenNF_Tc` \ con_id ->
 196     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
 197     let
 198              -- Ignore the con_theta; overloaded constructors only
 199              -- behave differently when called, not when used for
 200              -- matching.
 201         (_, record_ty) = splitFunTy con_tau
 202     in
 203         -- Con is syntactically constrained to be a data constructor
 204     ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
 205
 206     mapAndUnzipTc (do_bind record_ty) rpats     `thenTc` \ (rpats', lies) ->
 207
 208     returnTc (RecPat con_id record_ty rpats',
 209               plusLIEs lies,
 210               record_ty)
 211
 212   where
 213     do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
 214       = tcLookupGlobalValue field_label         `thenNF_Tc` \ sel_id ->
 215         tcInstId sel_id                         `thenNF_Tc` \ (_, _, tau) ->
 216
 217                 -- Record selectors all have type
 218                 --      forall a1..an.  T a1 .. an -> tau
 219         ASSERT( maybeToBool (getFunTy_maybe tau) )
 220         let
 221                 -- Selector must have type RecordType -> FieldType
 222           Just (record_ty, field_ty) = getFunTy_maybe tau
 223         in
 224         tcAddErrCtxt (recordLabel field_label) (
 225           unifyTauTy expected_record_ty record_ty
 226         )                                               `thenTc_`
 227         tcPat rhs_pat                                   `thenTc` \ (rhs_pat', lie, rhs_ty) ->
 228         tcAddErrCtxt (recordRhs field_label rhs_pat) (
 229           unifyTauTy field_ty rhs_ty
 230         )                                               `thenTc_`
 231         returnTc ((sel_id, rhs_pat', pun_flag), lie)
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection{Non-overloaded literals}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 tcPat (LitPatIn lit@(HsChar str))
 242   = returnTc (LitPat lit charTy, emptyLIE, charTy)
 243
 244 tcPat (LitPatIn lit@(HsString str))
 245   = tcLookupGlobalValueByKey eqClassOpKey       `thenNF_Tc` \ sel_id ->
 246     newMethod (LiteralOrigin lit)
 247               (RealId sel_id) [stringTy]        `thenNF_Tc` \ (lie, eq_id) ->
 248     let
 249         comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
 250     in
 251     returnTc (NPat lit stringTy comp_op, lie, stringTy)
 252
 253 tcPat (LitPatIn lit@(HsIntPrim _))
 254   = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
 255 tcPat (LitPatIn lit@(HsCharPrim _))
 256   = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
 257 tcPat (LitPatIn lit@(HsStringPrim _))
 258   = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
 259 tcPat (LitPatIn lit@(HsFloatPrim _))
 260   = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
 261 tcPat (LitPatIn lit@(HsDoublePrim _))
 262   = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
 263 \end{code}
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 \begin{code}
 272 tcPat (LitPatIn lit@(HsInt i))
 273   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 274     newOverloadedLit origin
 275                      (OverloadedIntegral i) tyvar_ty    `thenNF_Tc` \ (lie1, over_lit_id) ->
 276
 277     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 278     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 279
 280     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 281                                        (HsVar over_lit_id)),
 282               lie1 `plusLIE` lie2,
 283               tyvar_ty)
 284   where
 285     origin = LiteralOrigin lit
 286
 287 tcPat (LitPatIn lit@(HsFrac f))
 288   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 289     newOverloadedLit origin
 290                      (OverloadedFractional f) tyvar_ty  `thenNF_Tc` \ (lie1, over_lit_id) ->
 291
 292     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 293     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 294
 295     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 296                                        (HsVar over_lit_id)),
 297               lie1 `plusLIE` lie2,
 298               tyvar_ty)
 299   where
 300     origin = LiteralOrigin lit
 301
 302 tcPat (LitPatIn lit@(HsLitLit s))
 303   = error "tcPat: can't handle ``literal-literal'' patterns"
 304 \end{code}
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection{Lists of patterns}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 \begin{code}
 313 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
 314
 315 tcPats [] = returnTc ([], emptyLIE, [])
 316
 317 tcPats (pat:pats)
 318   = tcPat pat           `thenTc` \ (pat',  lie,  ty)  ->
 319     tcPats pats         `thenTc` \ (pats', lie', tys) ->
 320
 321     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 322 \end{code}
 323
 324 @matchConArgTys@ grabs the signature of the data constructor, and
 325 unifies the actual args against the expected ones.
 326
 327 \begin{code}
 328 matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
 329
 330 matchConArgTys con arg_tys
 331   = tcLookupGlobalValue con             `thenNF_Tc` \ con_id ->
 332     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
 333              -- Ignore the con_theta; overloaded constructors only
 334              -- behave differently when called, not when used for
 335              -- matching.
 336     let
 337         (con_args, con_result) = splitFunTy con_tau
 338         con_arity  = length con_args
 339         no_of_args = length arg_tys
 340     in
 341     checkTc (con_arity == no_of_args)
 342             (arityErr "Constructor" con_id con_arity no_of_args)        `thenTc_`
 343
 344     unifyTauTyLists arg_tys con_args                                    `thenTc_`
 345     returnTc (con_id, con_result)
 346 \end{code}
 347
 348
 349 % =================================================
 350
 351 Errors and contexts
 352 ~~~~~~~~~~~~~~~~~~~
 353 \begin{code}
 354 patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
 355
 356 recordLabel field_label sty
 357   = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
 358          4 (ppBesides [ppStr "with its immediately enclosing constructor"])
 359
 360 recordRhs field_label pat sty
 361   = ppHang (ppStr "In the record field pattern")
 362          4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])
 363 \end{code}