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