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