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