ghc/compiler/typecheck/TcPat.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcPat]{Typechecking patterns}
   5
   6 \begin{code}
   7 module TcPat ( tcPat, tcPatBndr_NoSigs, badFieldCon, polyPatSig ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-}   TcExpr( tcExpr )
  12
  13 import HsSyn            ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
  14 import RnHsSyn          ( RenamedPat )
  15 import TcHsSyn          ( TcPat, TcId )
  16
  17 import TcMonad
  18 import Inst             ( Inst, OverloadedLit(..), InstOrigin(..),
  19                           emptyLIE, plusLIE, LIE,
  20                           newMethod, newOverloadedLit, newDicts, newClassDicts
  21                         )
  22 import Name             ( Name, getOccName, getSrcLoc )
  23 import FieldLabel       ( fieldLabelName )
  24 import TcEnv            ( tcLookupValue, tcLookupClassByKey,
  25                           tcLookupValueByKey, newLocalId, badCon
  26                         )
  27 import TcType           ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
  28 import TcMonoType       ( tcHsSigType )
  29 import TcUnify          ( unifyTauTy, unifyListTy, unifyTupleTy )
  30
  31 import CmdLineOpts      ( opt_IrrefutableTuples )
  32 import DataCon          ( DataCon, dataConSig, dataConFieldLabels,
  33                           dataConSourceArity
  34                         )
  35 import Id               ( Id, idType, isDataConWrapId_maybe )
  36 import Type             ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind )
  37 import PprType          ( {- instance Outputable Type -} )
  38 import Subst            ( substTy, substClasses )
  39 import TysPrim          ( charPrimTy, intPrimTy, floatPrimTy,
  40                           doublePrimTy, addrPrimTy
  41                         )
  42 import TysWiredIn       ( charTy, stringTy, intTy )
  43 import SrcLoc           ( SrcLoc )
  44 import Unique           ( eqClassOpKey, geClassOpKey, minusClassOpKey,
  45                           cCallableClassKey
  46                         )
  47 import BasicTypes       ( isBoxed )
  48 import Bag
  49 import Util             ( zipEqual )
  50 import Outputable
  51 \end{code}
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56 \subsection{Variable patterns}
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61 -- This is the right function to pass to tcPat when there are no signatures
  62 tcPatBndr_NoSigs binder_name pat_ty
  63   =     -- Need to make a new, monomorphic, Id
  64         -- The binder_name is already being used for the polymorphic Id
  65      newLocalId (getOccName binder_name) pat_ty loc     `thenNF_Tc` \ bndr_id ->
  66      returnTc bndr_id
  67  where
  68    loc = getSrcLoc binder_name
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{Typechecking patterns}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorphic)
  80                                         -- Id for variables found in the pattern
  81                                         -- The TcType is the expected type, see note below
  82       -> RenamedPat
  83
  84       -> TcType         -- Expected type derived from the context
  85                         --      In the case of a function with a rank-2 signature,
  86                         --      this type might be a forall type.
  87                         --      INVARIANT: if it is, the foralls will always be visible,
  88                         --      not hidden inside a mutable type variable
  89
  90       -> TcM s (TcPat,
  91                 LIE,                    -- Required by n+k and literal pats
  92                 Bag TcTyVar,    -- TyVars bound by the pattern
  93                                         --      These are just the existentially-bound ones.
  94                                         --      Any tyvars bound by *type signatures* in the
  95                                         --      patterns are brought into scope before we begin.
  96                 Bag (Name, TcId),       -- Ids bound by the pattern, along with the Name under
  97                                         --      which it occurs in the pattern
  98                                         --      The two aren't the same because we conjure up a new
  99                                         --      local name for each variable.
 100                 LIE)                    -- Dicts or methods [see below] bound by the pattern
 101                                         --      from existential constructor patterns
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{Variables, wildcards, lazy pats, as-pats}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 \begin{code}
 112 tcPat tc_bndr (VarPatIn name) pat_ty
 113   = tc_bndr name pat_ty         `thenTc` \ bndr_id ->
 114     returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
 115
 116 tcPat tc_bndr (LazyPatIn pat) pat_ty
 117   = tcPat tc_bndr pat pat_ty            `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
 118     returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
 119
 120 tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
 121   = tc_bndr name pat_ty                 `thenTc` \ bndr_id ->
 122     tcPat tc_bndr pat pat_ty            `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
 123     tcAddErrCtxt (patCtxt pat_in)       $
 124     returnTc (AsPat bndr_id pat', lie_req,
 125               tvs, (name, bndr_id) `consBag` ids, lie_avail)
 126
 127 tcPat tc_bndr WildPatIn pat_ty
 128   = returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
 129
 130 tcPat tc_bndr (NegPatIn pat) pat_ty
 131   = tcPat tc_bndr (negate_lit pat) pat_ty
 132   where
 133     negate_lit (LitPatIn (HsInt  i))       = LitPatIn (HsInt  (-i))
 134     negate_lit (LitPatIn (HsIntPrim i))    = LitPatIn (HsIntPrim (-i))
 135     negate_lit (LitPatIn (HsFrac f))       = LitPatIn (HsFrac (-f))
 136     negate_lit (LitPatIn (HsFloatPrim f))  = LitPatIn (HsFloatPrim (-f))
 137     negate_lit (LitPatIn (HsDoublePrim f)) = LitPatIn (HsDoublePrim (-f))
 138     negate_lit _                           = panic "TcPat:negate_pat"
 139
 140 tcPat tc_bndr (ParPatIn parend_pat) pat_ty
 141   = tcPat tc_bndr parend_pat pat_ty
 142
 143 tcPat tc_bndr (SigPatIn pat sig) pat_ty
 144   = tcHsSigType sig                                     `thenTc` \ sig_ty ->
 145
 146         -- Check that the signature isn't a polymorphic one, which
 147         -- we don't permit (at present, anyway)
 148     checkTc (isTauTy sig_ty) (polyPatSig sig_ty)        `thenTc_`
 149
 150     unifyTauTy pat_ty sig_ty    `thenTc_`
 151     tcPat tc_bndr pat sig_ty
 152 \end{code}
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection{Explicit lists and tuples}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
 162   = tcAddErrCtxt (patCtxt pat_in)               $
 163     unifyListTy pat_ty                          `thenTc` \ elem_ty ->
 164     tcPats tc_bndr pats (repeat elem_ty)        `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
 165     returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
 166
 167 tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
 168   = tcAddErrCtxt (patCtxt pat_in)       $
 169
 170     unifyTupleTy boxity arity pat_ty            `thenTc` \ arg_tys ->
 171     tcPats tc_bndr pats arg_tys                 `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
 172
 173         -- possibly do the "make all tuple-pats irrefutable" test:
 174     let
 175         unmangled_result = TuplePat pats' boxity
 176
 177         -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 178         -- so that we can experiment with lazy tuple-matching.
 179         -- This is a pretty odd place to make the switch, but
 180         -- it was easy to do.
 181
 182         possibly_mangled_result
 183           | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
 184           | otherwise                               = unmangled_result
 185     in
 186     returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
 187   where
 188     arity = length pats
 189 \end{code}
 190
 191 %************************************************************************
 192 %*                                                                      *
 193 \subsection{Other constructors}
 194 %*                                                                      *
 195
 196 %************************************************************************
 197
 198 \begin{code}
 199 tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
 200   = tcConPat tc_bndr pat name arg_pats pat_ty
 201
 202 tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
 203   = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
 204 \end{code}
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection{Records}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
 215   = tcAddErrCtxt (patCtxt pat)  $
 216
 217         -- Check the constructor itself
 218     tcConstructor pat name pat_ty       `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
 219     let
 220         field_tys = zipEqual "tcPat"
 221                              (map fieldLabelName (dataConFieldLabels data_con))
 222                              arg_tys
 223     in
 224
 225         -- Check the fields
 226     tc_fields field_tys rpats           `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
 227
 228     returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
 229               lie_req,
 230               listToBag ex_tvs `unionBags` tvs,
 231               ids,
 232               lie_avail1 `plusLIE` lie_avail2)
 233
 234   where
 235     tc_fields field_tys []
 236       = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
 237
 238     tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
 239       = tc_fields field_tys rpats       `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
 240
 241         (case [ty | (f,ty) <- field_tys, f == field_label] of
 242
 243                 -- No matching field; chances are this field label comes from some
 244                 -- other record type (or maybe none).  As well as reporting an
 245                 -- error we still want to typecheck the pattern, principally to
 246                 -- make sure that all the variables it binds are put into the
 247                 -- environment, else the type checker crashes later:
 248                 --      f (R { foo = (a,b) }) = a+b
 249                 -- If foo isn't one of R's fields, we don't want to crash when
 250                 -- typechecking the "a+b".
 251            [] -> addErrTc (badFieldCon name field_label)        `thenNF_Tc_`
 252                  newTyVarTy boxedTypeKind                       `thenNF_Tc_`
 253                  returnTc (error "Bogus selector Id", pat_ty)
 254
 255                 -- The normal case, when the field comes from the right constructor
 256            (pat_ty : extras) ->
 257                 ASSERT( null extras )
 258                 tcLookupValue field_label                       `thenNF_Tc` \ sel_id ->
 259                 returnTc (sel_id, pat_ty)
 260         )                                                       `thenTc` \ (sel_id, pat_ty) ->
 261
 262         tcPat tc_bndr rhs_pat pat_ty    `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
 263
 264         returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
 265                   lie_req1 `plusLIE` lie_req2,
 266                   tvs1 `unionBags` tvs2,
 267                   ids1 `unionBags` ids2,
 268                   lie_avail1 `plusLIE` lie_avail2)
 269 \end{code}
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection{Non-overloaded literals}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 \begin{code}
 278 tcPat tc_bndr (LitPatIn lit@(HsChar _))       pat_ty = tcSimpleLitPat lit charTy       pat_ty
 279 tcPat tc_bndr (LitPatIn lit@(HsIntPrim _))    pat_ty = tcSimpleLitPat lit intPrimTy    pat_ty
 280 tcPat tc_bndr (LitPatIn lit@(HsCharPrim _))   pat_ty = tcSimpleLitPat lit charPrimTy   pat_ty
 281 tcPat tc_bndr (LitPatIn lit@(HsStringPrim _)) pat_ty = tcSimpleLitPat lit addrPrimTy   pat_ty
 282 tcPat tc_bndr (LitPatIn lit@(HsFloatPrim _))  pat_ty = tcSimpleLitPat lit floatPrimTy  pat_ty
 283 tcPat tc_bndr (LitPatIn lit@(HsDoublePrim _)) pat_ty = tcSimpleLitPat lit doublePrimTy pat_ty
 284
 285 tcPat tc_bndr (LitPatIn lit@(HsLitLit s))     pat_ty
 286         -- cf tcExpr on LitLits
 287   = tcLookupClassByKey cCallableClassKey                `thenNF_Tc` \ cCallableClass ->
 288     newDicts (LitLitOrigin (_UNPK_ s))
 289              [mkClassPred cCallableClass [pat_ty]]      `thenNF_Tc` \ (dicts, _) ->
 290     returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
 291 \end{code}
 292
 293 %************************************************************************
 294 %*                                                                      *
 295 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
 296 %*                                                                      *
 297 %************************************************************************
 298
 299 \begin{code}
 300 tcPat tc_bndr pat@(LitPatIn lit@(HsString str)) pat_ty
 301   = unifyTauTy pat_ty stringTy                  `thenTc_`
 302     tcLookupValueByKey eqClassOpKey             `thenNF_Tc` \ sel_id ->
 303     newMethod (PatOrigin pat) sel_id [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
 304     let
 305         comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
 306     in
 307     returnTc (NPat lit stringTy comp_op, lie, emptyBag, emptyBag, emptyLIE)
 308
 309
 310 tcPat tc_bndr pat@(LitPatIn lit@(HsInt i)) pat_ty
 311   = tcOverloadedLitPat pat lit (OverloadedIntegral i) pat_ty
 312
 313 tcPat tc_bndr pat@(LitPatIn lit@(HsFrac f)) pat_ty
 314   = tcOverloadedLitPat pat lit (OverloadedFractional f) pat_ty
 315
 316
 317 tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
 318   = tc_bndr name pat_ty                         `thenTc` \ bndr_id ->
 319     tcLookupValueByKey geClassOpKey             `thenNF_Tc` \ ge_sel_id ->
 320     tcLookupValueByKey minusClassOpKey          `thenNF_Tc` \ minus_sel_id ->
 321
 322     newOverloadedLit origin
 323                      (OverloadedIntegral i) pat_ty      `thenNF_Tc` \ (over_lit_expr, lie1) ->
 324
 325     newMethod origin ge_sel_id    [pat_ty]      `thenNF_Tc` \ (lie2, ge_id) ->
 326     newMethod origin minus_sel_id [pat_ty]      `thenNF_Tc` \ (lie3, minus_id) ->
 327
 328     returnTc (NPlusKPat bndr_id lit pat_ty
 329                         (SectionR (HsVar ge_id) over_lit_expr)
 330                         (SectionR (HsVar minus_id) over_lit_expr),
 331               lie1 `plusLIE` lie2 `plusLIE` lie3,
 332               emptyBag, unitBag (name, bndr_id), emptyLIE)
 333   where
 334     origin = PatOrigin pat
 335
 336 tcPat tc_bndr (NPlusKPatIn pat other) pat_ty
 337   = panic "TcPat:NPlusKPat: not an HsInt literal"
 338 \end{code}
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection{Lists of patterns}
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 Helper functions
 347
 348 \begin{code}
 349 tcPats :: (Name -> TcType -> TcM s TcId)        -- How to deal with variables
 350        -> [RenamedPat] -> [TcType]              -- Excess 'expected types' discarded
 351        -> TcM s ([TcPat],
 352                  LIE,                           -- Required by n+k and literal pats
 353                  Bag TcTyVar,
 354                  Bag (Name, TcId),      -- Ids bound by the pattern
 355                  LIE)                           -- Dicts bound by the pattern
 356
 357 tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
 358
 359 tcPats tc_bndr (ty:tys) (pat:pats)
 360   = tcPat tc_bndr ty pat                `thenTc` \ (pat',  lie_req1, tvs1, ids1, lie_avail1) ->
 361     tcPats tc_bndr tys pats     `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
 362
 363     returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
 364               tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
 365               lie_avail1 `plusLIE` lie_avail2)
 366 \end{code}
 367
 368 ------------------------------------------------------
 369 \begin{code}
 370 tcSimpleLitPat lit lit_ty pat_ty
 371   = unifyTauTy pat_ty lit_ty    `thenTc_`
 372     returnTc (LitPat lit lit_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
 373
 374
 375 tcOverloadedLitPat pat lit over_lit pat_ty
 376   = newOverloadedLit (PatOrigin pat) over_lit pat_ty    `thenNF_Tc` \ (over_lit_expr, lie1) ->
 377     tcLookupValueByKey eqClassOpKey                     `thenNF_Tc` \ eq_sel_id ->
 378     newMethod origin eq_sel_id [pat_ty]                 `thenNF_Tc` \ (lie2, eq_id) ->
 379
 380     returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
 381                                      over_lit_expr),
 382               lie1 `plusLIE` lie2,
 383               emptyBag, emptyBag, emptyLIE)
 384   where
 385     origin = PatOrigin pat
 386 \end{code}
 387
 388 ------------------------------------------------------
 389 \begin{code}
 390 tcConstructor pat con_name pat_ty
 391   =     -- Check that it's a constructor
 392     tcLookupValue con_name              `thenNF_Tc` \ con_id ->
 393     case isDataConWrapId_maybe con_id of {
 394         Nothing -> failWithTc (badCon con_id);
 395         Just data_con ->
 396
 397         -- Instantiate it
 398     let
 399         (tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 400              -- Ignore the theta; overloaded constructors only
 401              -- behave differently when called, not when used for
 402              -- matching.
 403     in
 404     tcInstTyVars (ex_tvs ++ tvs)        `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
 405     let
 406         ex_theta' = substClasses tenv ex_theta
 407         arg_tys'  = map (substTy tenv) arg_tys
 408
 409         n_ex_tvs  = length ex_tvs
 410         ex_tvs'   = take n_ex_tvs all_tvs'
 411         result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
 412     in
 413     newClassDicts (PatOrigin pat) ex_theta'     `thenNF_Tc` \ (lie_avail, dicts) ->
 414
 415         -- Check overall type matches
 416     unifyTauTy pat_ty result_ty         `thenTc_`
 417
 418     returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
 419     }
 420 \end{code}
 421
 422 ------------------------------------------------------
 423 \begin{code}
 424 tcConPat tc_bndr pat con_name arg_pats pat_ty
 425   = tcAddErrCtxt (patCtxt pat)  $
 426
 427         -- Check the constructor itself
 428     tcConstructor pat con_name pat_ty   `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
 429
 430         -- Check correct arity
 431     let
 432         con_arity  = dataConSourceArity data_con
 433         no_of_args = length arg_pats
 434     in
 435     checkTc (con_arity == no_of_args)
 436             (arityErr "Constructor" data_con con_arity no_of_args)      `thenTc_`
 437
 438         -- Check arguments
 439     tcPats tc_bndr arg_pats arg_tys'    `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
 440
 441     returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
 442               lie_req,
 443               listToBag ex_tvs' `unionBags` tvs,
 444               ids,
 445               lie_avail1 `plusLIE` lie_avail2)
 446 \end{code}
 447
 448
 449 %************************************************************************
 450 %*                                                                      *
 451 \subsection{Errors and contexts}
 452 %*                                                                      *
 453 %************************************************************************
 454
 455 \begin{code}
 456 patCtxt pat = hang (ptext SLIT("In the pattern:"))
 457                  4 (ppr pat)
 458
 459 recordLabel field_label
 460   = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
 461          4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
 462
 463 recordRhs field_label pat
 464   = hang (ptext SLIT("In the record field pattern"))
 465          4 (sep [ppr field_label, char '=', ppr pat])
 466
 467 badFieldCon :: Name -> Name -> SDoc
 468 badFieldCon con field
 469   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
 470           ptext SLIT("does not have field"), quotes (ppr field)]
 471
 472 polyPatSig :: TcType -> SDoc
 473 polyPatSig sig_ty
 474   = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
 475          4 (ppr sig_ty)
 476 \end{code}
 477