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