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, Qualifier, HsType, Fixity,
  15                           ArithSeqInfo, Stmt, 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 )
  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 \end{code}
 307
 308 %************************************************************************
 309 %*                                                                      *
 310 \subsection{Lists of patterns}
 311 %*                                                                      *
 312 %************************************************************************
 313
 314 \begin{code}
 315 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
 316
 317 tcPats [] = returnTc ([], emptyLIE, [])
 318
 319 tcPats (pat:pats)
 320   = tcPat pat           `thenTc` \ (pat',  lie,  ty)  ->
 321     tcPats pats         `thenTc` \ (pats', lie', tys) ->
 322
 323     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 324 \end{code}
 325
 326 @matchConArgTys@ grabs the signature of the data constructor, and
 327 unifies the actual args against the expected ones.
 328
 329 \begin{code}
 330 matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
 331
 332 matchConArgTys con arg_tys
 333   = tcLookupGlobalValue con             `thenNF_Tc` \ con_id ->
 334     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
 335              -- Ignore the con_theta; overloaded constructors only
 336              -- behave differently when called, not when used for
 337              -- matching.
 338     let
 339         (con_args, con_result) = splitFunTy con_tau
 340         con_arity  = length con_args
 341         no_of_args = length arg_tys
 342     in
 343     checkTc (con_arity == no_of_args)
 344             (arityErr "Constructor" con_id con_arity no_of_args)        `thenTc_`
 345
 346     unifyTauTyLists con_args arg_tys                                    `thenTc_`
 347     returnTc (con_id, con_result)
 348 \end{code}
 349
 350
 351 % =================================================
 352
 353 Errors and contexts
 354 ~~~~~~~~~~~~~~~~~~~
 355 \begin{code}
 356 patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
 357
 358 recordLabel field_label sty
 359   = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label])
 360          4 (ppBesides [ppStr "with its immediately enclosing constructor"])
 361
 362 recordRhs field_label pat sty
 363   = ppHang (ppStr "In the record field pattern")
 364          4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat])
 365 \end{code}