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 Bag              ( Bag )
  28 import CmdLineOpts      ( opt_IrrefutableTuples )
  29 import Id               ( GenId, idType, Id )
  30 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind )
  31 import PprType          ( GenType, GenTyVar )
  32 import Type             ( splitFunTys, splitRhoTy,
  33                           splitFunTy_maybe,
  34                           Type, GenType
  35                         )
  36 import TyVar            ( GenTyVar )
  37 import TysPrim          ( charPrimTy, intPrimTy, floatPrimTy,
  38                           doublePrimTy, addrPrimTy
  39                         )
  40 import TysWiredIn       ( charTy, stringTy, mkListTy, mkTupleTy )
  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     in
 199         -- Con is syntactically constrained to be a data constructor
 200     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) )
 201
 202     mapAndUnzipTc (do_bind record_ty) rpats     `thenTc` \ (rpats', lies) ->
 203
 204     returnTc (RecPat con_id record_ty rpats',
 205               plusLIEs lies,
 206               record_ty)
 207
 208   where
 209     do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
 210       = tcLookupGlobalValue field_label         `thenNF_Tc` \ sel_id ->
 211         tcInstId sel_id                         `thenNF_Tc` \ (_, _, tau) ->
 212
 213                 -- Record selectors all have type
 214                 --      forall a1..an.  T a1 .. an -> tau
 215         ASSERT( maybeToBool (splitFunTy_maybe tau) )
 216         let
 217                 -- Selector must have type RecordType -> FieldType
 218           Just (record_ty, field_ty) = splitFunTy_maybe tau
 219         in
 220         tcAddErrCtxt (recordLabel field_label) (
 221           unifyTauTy expected_record_ty record_ty
 222         )                                               `thenTc_`
 223         tcPat rhs_pat                                   `thenTc` \ (rhs_pat', lie, rhs_ty) ->
 224         tcAddErrCtxt (recordRhs field_label rhs_pat) (
 225           unifyTauTy field_ty rhs_ty
 226         )                                               `thenTc_`
 227         returnTc ((sel_id, rhs_pat', pun_flag), lie)
 228 \end{code}
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection{Non-overloaded literals}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 \begin{code}
 237 tcPat (LitPatIn lit@(HsChar str))
 238   = returnTc (LitPat lit charTy, emptyLIE, charTy)
 239
 240 tcPat (LitPatIn lit@(HsString str))
 241   = tcLookupGlobalValueByKey eqClassOpKey       `thenNF_Tc` \ sel_id ->
 242     newMethod (LiteralOrigin lit)
 243               (RealId sel_id) [stringTy]        `thenNF_Tc` \ (lie, eq_id) ->
 244     let
 245         comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
 246     in
 247     returnTc (NPat lit stringTy comp_op, lie, stringTy)
 248
 249 tcPat (LitPatIn lit@(HsIntPrim _))
 250   = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
 251 tcPat (LitPatIn lit@(HsCharPrim _))
 252   = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
 253 tcPat (LitPatIn lit@(HsStringPrim _))
 254   = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
 255 tcPat (LitPatIn lit@(HsFloatPrim _))
 256   = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
 257 tcPat (LitPatIn lit@(HsDoublePrim _))
 258   = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
 259 \end{code}
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 tcPat (LitPatIn lit@(HsInt i))
 269   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 270     newOverloadedLit origin
 271                      (OverloadedIntegral i) tyvar_ty    `thenNF_Tc` \ (over_lit_expr, lie1) ->
 272
 273     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 274     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 275
 276     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 277                                        over_lit_expr),
 278               lie1 `plusLIE` lie2,
 279               tyvar_ty)
 280   where
 281     origin = LiteralOrigin lit
 282
 283 tcPat (LitPatIn lit@(HsFrac f))
 284   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 285     newOverloadedLit origin
 286                      (OverloadedFractional f) tyvar_ty  `thenNF_Tc` \ (over_lit_expr, lie1) ->
 287
 288     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 289     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 290
 291     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 292                                        over_lit_expr),
 293               lie1 `plusLIE` lie2,
 294               tyvar_ty)
 295   where
 296     origin = LiteralOrigin lit
 297
 298 tcPat (LitPatIn lit@(HsLitLit s))
 299   = error "tcPat: can't handle ``literal-literal'' patterns"
 300
 301 tcPat (NPlusKPatIn name lit@(HsInt i))
 302   = tcLookupLocalValueOK "tcPat1:n+k" name      `thenNF_Tc` \ local ->
 303     let
 304         local_ty = idType local
 305     in
 306     tcLookupGlobalValueByKey geClassOpKey               `thenNF_Tc` \ ge_sel_id ->
 307     tcLookupGlobalValueByKey minusClassOpKey            `thenNF_Tc` \ minus_sel_id ->
 308
 309     newOverloadedLit origin
 310                      (OverloadedIntegral i) local_ty    `thenNF_Tc` \ (over_lit_expr, lie1) ->
 311
 312     newMethod origin (RealId ge_sel_id)    [local_ty]   `thenNF_Tc` \ (lie2, ge_id) ->
 313     newMethod origin (RealId minus_sel_id) [local_ty]   `thenNF_Tc` \ (lie3, minus_id) ->
 314
 315     returnTc (NPlusKPat (TcId local) lit local_ty
 316                         (SectionR (HsVar ge_id) over_lit_expr)
 317                         (SectionR (HsVar minus_id) over_lit_expr),
 318               lie1 `plusLIE` lie2 `plusLIE` lie3,
 319               local_ty)
 320   where
 321     origin = LiteralOrigin lit  -- Not very good!
 322
 323 tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal"
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection{Lists of patterns}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
 334
 335 tcPats [] = returnTc ([], emptyLIE, [])
 336
 337 tcPats (pat:pats)
 338   = tcPat pat           `thenTc` \ (pat',  lie,  ty)  ->
 339     tcPats pats         `thenTc` \ (pats', lie', tys) ->
 340
 341     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 342 \end{code}
 343
 344 @matchConArgTys@ grabs the signature of the data constructor, and
 345 unifies the actual args against the expected ones.
 346
 347 \begin{code}
 348 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
 349
 350 matchConArgTys con arg_tys
 351   = tcLookupGlobalValue con             `thenNF_Tc` \ con_id ->
 352     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
 353              -- Ignore the con_theta; overloaded constructors only
 354              -- behave differently when called, not when used for
 355              -- matching.
 356     let
 357         (con_args, con_result) = splitFunTys con_tau
 358         con_arity  = length con_args
 359         no_of_args = length arg_tys
 360     in
 361     checkTc (con_arity == no_of_args)
 362             (arityErr "Constructor" con_id con_arity no_of_args)        `thenTc_`
 363
 364     unifyTauTyLists con_args arg_tys                                    `thenTc_`
 365     returnTc (con_id, con_result)
 366 \end{code}
 367
 368
 369 % =================================================
 370
 371 Errors and contexts
 372 ~~~~~~~~~~~~~~~~~~~
 373 \begin{code}
 374 patCtxt pat = hang (ptext SLIT("In the pattern:"))
 375                  4 (ppr pat)
 376
 377 recordLabel field_label
 378   = hang (hcat [ptext SLIT("When matching record field"), ppr field_label])
 379          4 (hcat [ptext SLIT("with its immediately enclosing constructor")])
 380
 381 recordRhs field_label pat
 382   = hang (ptext SLIT("In the record field pattern"))
 383          4 (sep [ppr field_label, char '=', ppr pat])
 384 \end{code}