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