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