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