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 )
  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 \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   = tcLookupGlobalValue name            `thenNF_Tc` \ con_id ->
 185     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
 186     let
 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       = tcLookupGlobalValue field_label         `thenNF_Tc` \ sel_id ->
 204         tcInstId sel_id                         `thenNF_Tc` \ (_, _, tau) ->
 205
 206                 -- Record selectors all have type
 207                 --      forall a1..an.  T a1 .. an -> tau
 208         ASSERT( maybeToBool (getFunTy_maybe tau) )
 209         let
 210                 -- Selector must have type RecordType -> FieldType
 211           Just (record_ty, field_ty) = getFunTy_maybe tau
 212         in
 213         tcAddErrCtxt (recordLabel field_label) (
 214           unifyTauTy expected_record_ty record_ty
 215         )                                               `thenTc_`
 216         tcPat rhs_pat                                   `thenTc` \ (rhs_pat', lie, rhs_ty) ->
 217         tcAddErrCtxt (recordRhs field_label rhs_pat) (
 218           unifyTauTy field_ty rhs_ty
 219         )                                               `thenTc_`
 220         returnTc ((sel_id, rhs_pat', pun_flag), lie)
 221 \end{code}
 222
 223 %************************************************************************
 224 %*                                                                      *
 225 \subsection{Non-overloaded literals}
 226 %*                                                                      *
 227 %************************************************************************
 228
 229 \begin{code}
 230 tcPat (LitPatIn lit@(HsChar str))
 231   = returnTc (LitPat lit charTy, emptyLIE, charTy)
 232
 233 tcPat (LitPatIn lit@(HsString str))
 234   = tcLookupGlobalValueByKey eqClassOpKey       `thenNF_Tc` \ sel_id ->
 235     newMethod (LiteralOrigin lit)
 236               (RealId sel_id) [stringTy]        `thenNF_Tc` \ (lie, eq_id) ->
 237     let
 238         comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
 239     in
 240     returnTc (NPat lit stringTy comp_op, lie, stringTy)
 241
 242 tcPat (LitPatIn lit@(HsIntPrim _))
 243   = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
 244 tcPat (LitPatIn lit@(HsCharPrim _))
 245   = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
 246 tcPat (LitPatIn lit@(HsStringPrim _))
 247   = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
 248 tcPat (LitPatIn lit@(HsFloatPrim _))
 249   = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
 250 tcPat (LitPatIn lit@(HsDoublePrim _))
 251   = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
 252 \end{code}
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 \begin{code}
 261 tcPat (LitPatIn lit@(HsInt i))
 262   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 263     newOverloadedLit origin
 264                      (OverloadedIntegral i) tyvar_ty    `thenNF_Tc` \ (lie1, over_lit_id) ->
 265
 266     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 267     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 268
 269     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 270                                        (HsVar over_lit_id)),
 271               lie1 `plusLIE` lie2,
 272               tyvar_ty)
 273   where
 274     origin = LiteralOrigin lit
 275
 276 tcPat (LitPatIn lit@(HsFrac f))
 277   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 278     newOverloadedLit origin
 279                      (OverloadedFractional f) tyvar_ty  `thenNF_Tc` \ (lie1, over_lit_id) ->
 280
 281     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 282     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 283
 284     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 285                                        (HsVar over_lit_id)),
 286               lie1 `plusLIE` lie2,
 287               tyvar_ty)
 288   where
 289     origin = LiteralOrigin lit
 290
 291 tcPat (LitPatIn lit@(HsLitLit s))
 292   = error "tcPat: can't handle ``literal-literal'' patterns"
 293 \end{code}
 294
 295 %************************************************************************
 296 %*                                                                      *
 297 \subsection{Lists of patterns}
 298 %*                                                                      *
 299 %************************************************************************
 300
 301 \begin{code}
 302 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
 303
 304 tcPats [] = returnTc ([], emptyLIE, [])
 305
 306 tcPats (pat:pats)
 307   = tcPat pat           `thenTc` \ (pat',  lie,  ty)  ->
 308     tcPats pats         `thenTc` \ (pats', lie', tys) ->
 309
 310     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 311 \end{code}
 312
 313 @matchConArgTys@ grabs the signature of the data constructor, and
 314 unifies the actual args against the expected ones.
 315
 316 \begin{code}
 317 matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
 318
 319 matchConArgTys con arg_tys
 320   = tcLookupGlobalValue con             `thenNF_Tc` \ con_id ->
 321     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
 322              -- Ignore the con_theta; overloaded constructors only
 323              -- behave differently when called, not when used for
 324              -- matching.
 325     let
 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}