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