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