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(..), LIE(..),
  21                           emptyLIE, plusLIE, newMethod, newOverloadedLit )
  22 import TcEnv            ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
  23                           tcLookupLocalValueOK )
  24 import TcType           ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys )
  25 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists )
  26
  27 import Bag              ( Bag )
  28 import CmdLineOpts      ( opt_IrrefutableTuples )
  29 import ErrUtils         ( arityErr )
  30 import Id               ( GenId, idType )
  31 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind )
  32 import Name             ( Name )
  33 import PprType          ( GenType, GenTyVar )
  34 import PrelInfo         ( charPrimTy, intPrimTy, floatPrimTy,
  35                           doublePrimTy, charTy, stringTy, mkListTy,
  36                           mkTupleTy, addrTy, addrPrimTy )
  37 import Pretty
  38 import Type             ( Type(..), GenType, splitFunTy, splitSigmaTy )
  39 import TyVar            ( GenTyVar )
  40 import Unique           ( Unique, eqClassOpKey )
  41
  42 \end{code}
  43
  44 \begin{code}
  45 tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{Variables, wildcards, lazy pats, as-pats}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 \begin{code}
  55 tcPat (VarPatIn name)
  56   = tcLookupLocalValueOK "tcPat1" name  `thenNF_Tc` \ id ->
  57     returnTc (VarPat (TcId id), emptyLIE, idType id)
  58
  59 tcPat (LazyPatIn pat)
  60   = tcPat pat           `thenTc` \ (pat', lie, ty) ->
  61     returnTc (LazyPat pat', lie, ty)
  62
  63 tcPat pat_in@(AsPatIn name pat)
  64   = tcLookupLocalValueOK "tcPat2"  name `thenNF_Tc` \ id ->
  65     tcPat pat                           `thenTc` \ (pat', lie, ty) ->
  66     tcAddErrCtxt (patCtxt pat_in)       $
  67     unifyTauTy (idType id) ty           `thenTc_`
  68     returnTc (AsPat (TcId id) pat', lie, ty)
  69
  70 tcPat (WildPatIn)
  71   = newTyVarTy mkTypeKind       `thenNF_Tc` \ tyvar_ty ->
  72     returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
  73 \end{code}
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsection{Explicit lists and tuples}
  78 %*                                                                      *
  79 %************************************************************************
  80
  81 \begin{code}
  82 tcPat pat_in@(ListPatIn pats)
  83   = tcPats pats                         `thenTc`    \ (pats', lie, tys) ->
  84     newTyVarTy mkBoxedTypeKind          `thenNF_Tc` \ tyvar_ty ->
  85     tcAddErrCtxt (patCtxt pat_in)       $
  86     unifyTauTyList (tyvar_ty:tys)       `thenTc_`
  87
  88     returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
  89
  90 tcPat pat_in@(TuplePatIn pats)
  91   = let
  92         arity = length pats
  93     in
  94     tcPats pats                         `thenTc` \ (pats', lie, tys) ->
  95
  96         -- Make sure we record that the tuples can only contain boxed types
  97     newTyVarTys arity mkBoxedTypeKind   `thenNF_Tc` \ tyvar_tys ->
  98
  99     tcAddErrCtxt (patCtxt pat_in)       $
 100     unifyTauTyLists tyvar_tys tys       `thenTc_`
 101
 102         -- possibly do the "make all tuple-pats irrefutable" test:
 103     let
 104         unmangled_result = TuplePat pats'
 105
 106         -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 107         -- so that we can experiment with lazy tuple-matching.
 108         -- This is a pretty odd place to make the switch, but
 109         -- it was easy to do.
 110
 111         possibly_mangled_result
 112           = if opt_IrrefutableTuples
 113             then LazyPat unmangled_result
 114             else unmangled_result
 115
 116         -- ToDo: IrrefutableEverything
 117     in
 118     returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
 119 \end{code}
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection{Other constructors}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 Constructor patterns are a little fun:
 128 \begin{itemize}
 129 \item
 130 typecheck the arguments
 131 \item
 132 look up the constructor
 133 \item
 134 specialise its type (ignore the translation this produces)
 135 \item
 136 check that the context produced by this specialisation is empty
 137 \item
 138 get the arguments out of the function type produced from specialising
 139 \item
 140 unify them with the types of the patterns
 141 \item
 142 back substitute with the type of the result of the constructor
 143 \end{itemize}
 144
 145 ToDo: exploit new representation of constructors to make this more
 146 efficient?
 147
 148 \begin{code}
 149 tcPat pat_in@(ConPatIn name pats)
 150   = tcLookupGlobalValue name            `thenNF_Tc` \ con_id ->
 151
 152     tcPats pats                         `thenTc` \ (pats', lie, tys) ->
 153
 154     tcAddErrCtxt (patCtxt pat_in)       $
 155     matchConArgTys con_id tys           `thenTc` \ data_ty ->
 156
 157     returnTc (ConPat con_id data_ty pats',
 158               lie,
 159               data_ty)
 160
 161 tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
 162   = tcLookupGlobalValue op              `thenNF_Tc` \ con_id ->
 163
 164     tcPat pat1                          `thenTc` \ (pat1', lie1, ty1) ->
 165     tcPat pat2                          `thenTc` \ (pat2', lie2, ty2) ->
 166
 167     tcAddErrCtxt (patCtxt pat_in)       $
 168     matchConArgTys con_id [ty1,ty2]     `thenTc` \ data_ty ->
 169
 170     returnTc (ConOpPat pat1' con_id pat2' data_ty,
 171               lie1 `plusLIE` lie2,
 172               data_ty)
 173 \end{code}
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection{Non-overloaded literals}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 tcPat (LitPatIn lit@(HsChar str))
 183   = returnTc (LitPat lit charTy, emptyLIE, charTy)
 184
 185 tcPat (LitPatIn lit@(HsString str))
 186   = tcLookupGlobalValueByKey eqClassOpKey       `thenNF_Tc` \ sel_id ->
 187     newMethod (LiteralOrigin lit)
 188               (RealId sel_id) [stringTy]        `thenNF_Tc` \ (lie, eq_id) ->
 189     let
 190         comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
 191     in
 192     returnTc (NPat lit stringTy comp_op, lie, stringTy)
 193
 194 tcPat (LitPatIn lit@(HsIntPrim _))
 195   = returnTc (LitPat lit intPrimTy, emptyLIE, intPrimTy)
 196 tcPat (LitPatIn lit@(HsCharPrim _))
 197   = returnTc (LitPat lit charPrimTy, emptyLIE, charPrimTy)
 198 tcPat (LitPatIn lit@(HsStringPrim _))
 199   = returnTc (LitPat lit addrPrimTy, emptyLIE, addrPrimTy)
 200 tcPat (LitPatIn lit@(HsFloatPrim _))
 201   = returnTc (LitPat lit floatPrimTy, emptyLIE, floatPrimTy)
 202 tcPat (LitPatIn lit@(HsDoublePrim _))
 203   = returnTc (LitPat lit doublePrimTy, emptyLIE, doublePrimTy)
 204 \end{code}
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 tcPat (LitPatIn lit@(HsInt i))
 214   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 215     newOverloadedLit origin
 216                      (OverloadedIntegral i) tyvar_ty    `thenNF_Tc` \ (lie1, over_lit_id) ->
 217
 218     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 219     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 220
 221     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 222                                        (HsVar over_lit_id)),
 223               lie1 `plusLIE` lie2,
 224               tyvar_ty)
 225   where
 226     origin = LiteralOrigin lit
 227
 228 tcPat (LitPatIn lit@(HsFrac f))
 229   = newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ tyvar_ty ->
 230     newOverloadedLit origin
 231                      (OverloadedFractional f) tyvar_ty  `thenNF_Tc` \ (lie1, over_lit_id) ->
 232
 233     tcLookupGlobalValueByKey eqClassOpKey               `thenNF_Tc` \ eq_sel_id ->
 234     newMethod origin (RealId eq_sel_id) [tyvar_ty]      `thenNF_Tc` \ (lie2, eq_id) ->
 235
 236     returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id)
 237                                        (HsVar over_lit_id)),
 238               lie1 `plusLIE` lie2,
 239               tyvar_ty)
 240   where
 241     origin = LiteralOrigin lit
 242
 243 tcPat (LitPatIn lit@(HsLitLit s))
 244   = error "tcPat: can't handle ``literal-literal'' patterns"
 245 \end{code}
 246
 247 %************************************************************************
 248 %*                                                                      *
 249 \subsection{Lists of patterns}
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 \begin{code}
 254 tcPats :: [RenamedPat] -> TcM s ([TcPat s], LIE s, [TcType s])
 255
 256 tcPats [] = returnTc ([], emptyLIE, [])
 257
 258 tcPats (pat:pats)
 259   = tcPat pat           `thenTc` \ (pat',  lie,  ty)  ->
 260     tcPats pats         `thenTc` \ (pats', lie', tys) ->
 261
 262     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 263 \end{code}
 264
 265 @matchConArgTys@ grabs the signature of the data constructor, and
 266 unifies the actual args against the expected ones.
 267
 268 \begin{code}
 269 matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s)
 270
 271 matchConArgTys con_id arg_tys
 272   = tcInstType [] (idType con_id)               `thenNF_Tc` \ con_ty ->
 273     let
 274         no_of_args = length arg_tys
 275         (con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty
 276              -- Ignore the sig_theta; overloaded constructors only
 277              -- behave differently when called, not when used for
 278              -- matching.
 279         (con_args, con_result) = splitFunTy con_tau
 280         con_arity  = length con_args
 281     in
 282     checkTc (con_arity == no_of_args)
 283             (arityErr "Constructor" con_id con_arity no_of_args)        `thenTc_`
 284
 285     unifyTauTyLists arg_tys con_args                                    `thenTc_`
 286     returnTc con_result
 287 \end{code}
 288
 289
 290 % =================================================
 291
 292 Errors and contexts
 293 ~~~~~~~~~~~~~~~~~~~
 294 \begin{code}
 295 patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat)
 296 \end{code}