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