ghc/compiler/typecheck/TcPat.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcPat]{Typechecking patterns}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcPat (
  10         tcPat
  11 #ifdef DPH
  12         , tcPats
  13 #endif
  14     ) where
  15
  16 import TcMonad          -- typechecking monad machinery
  17 import TcMonadFns       ( newOpenTyVarTy, newPolyTyVarTy,
  18                           newPolyTyVarTys, copyTyVars, newMethod,
  19                           newOverloadedLit
  20                         )
  21 import AbsSyn           -- the stuff being typechecked
  22
  23 import AbsPrel          ( charPrimTy, intPrimTy, floatPrimTy,
  24                           doublePrimTy, charTy, stringTy, mkListTy,
  25                           mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId
  26                           PrimOp
  27                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  28                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  29 #ifdef DPH
  30                           ,mkProcessorTy, toDomainId
  31 #endif {- Data Parallel Haskell -}
  32                         )
  33 import AbsUniType       ( instantiateTauTy, applyTyCon, InstTyEnv(..)
  34                           IF_ATTACK_PRAGMAS(COMMA instantiateTy)
  35                         )
  36 import CmdLineOpts      ( GlobalSwitch(..) )
  37 import Id               ( mkInstId, getIdUniType, getDataConSig,
  38                           getInstantiatedDataConSig, Id, DataCon(..)
  39                         )
  40 import Inst
  41 import E                ( lookupE_Binder, lookupE_Value,
  42                           lookupE_ClassOpByKey, E,
  43                           LVE(..), TCE(..), UniqFM, CE(..)
  44                         -- TCE and CE for pragmas only
  45                         )
  46 import Errors           ( dataConArityErr, Error(..), UnifyErrContext(..)
  47                         )
  48 import LIE              ( nullLIE, plusLIE, mkLIE, LIE )
  49 import Unify
  50 import Unique           -- some ClassKey stuff
  51 import Util
  52
  53 #ifdef DPH
  54 import TcParQuals
  55 #endif {- Data Parallel Haskell -}
  56 \end{code}
  57
  58 The E passed in already contains bindings for all the variables in
  59 the pattern, usually to fresh type variables (but maybe not, if there
  60 were type signatures present).
  61
  62 \begin{code}
  63 tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType)
  64 \end{code}
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection{Variables, wildcards, lazy pats, as-pats}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 \begin{code}
  73 tcPat e (VarPatIn name)
  74   = let
  75         id = lookupE_Binder e name
  76     in
  77     returnTc (VarPat id, nullLIE, getIdUniType id)
  78
  79 tcPat e (LazyPatIn pat)
  80   = tcPat e pat         `thenTc` \ (pat', lie, ty) ->
  81     returnTc (LazyPat pat', lie, ty)
  82
  83 tcPat e pat_in@(AsPatIn name pat)
  84   = let
  85         id = lookupE_Binder e name
  86     in
  87     tcPat e pat                         `thenTc` \ (pat', lie, ty) ->
  88     unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_`
  89     returnTc (AsPat id pat', lie, ty)
  90
  91 tcPat e (WildPatIn)
  92   = newOpenTyVarTy    `thenNF_Tc` \ tyvar_ty ->
  93     returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty)
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection{Explicit lists and tuples}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103 tcPat e pat_in@(ListPatIn pats)
 104   = tcPats e pats       `thenTc`    \ (pats', lie, tys) ->
 105     newPolyTyVarTy      `thenNF_Tc` \ tyvar_ty ->
 106
 107     unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_`
 108
 109     returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty)
 110
 111 tcPat e pat_in@(TuplePatIn pats)
 112   = let
 113         arity = length pats
 114     in
 115     tcPats e pats   `thenTc` \ (pats', lie, tys) ->
 116
 117         -- We have to unify with fresh polymorphic type variables, to
 118         -- make sure we record that the tuples can only contain boxed
 119         -- types.
 120     newPolyTyVarTys arity   `thenNF_Tc` \ tyvar_tys ->
 121
 122     unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_`
 123
 124         -- possibly do the "make all tuple-pats irrefutable" test:
 125     getSwitchCheckerTc  `thenNF_Tc` \ sw_chkr ->
 126     let
 127         unmangled_result = TuplePat pats'
 128
 129         -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 130         -- so that we can experiment with lazy tuple-matching.
 131         -- This is a pretty odd place to make the switch, but
 132         -- it was easy to do.
 133         possibly_mangled_result
 134           = if sw_chkr IrrefutableTuples
 135             then LazyPat unmangled_result
 136             else unmangled_result
 137
 138         -- ToDo: IrrefutableEverything
 139     in
 140     returnTc (possibly_mangled_result, lie, mkTupleTy arity tys)
 141 \end{code}
 142
 143 %************************************************************************
 144 %*                                                                      *
 145 \subsection{Other constructors}
 146 %*                                                                      *
 147 %************************************************************************
 148
 149 Constructor patterns are a little fun:
 150 \begin{itemize}
 151 \item
 152 typecheck the arguments
 153 \item
 154 look up the constructor
 155 \item
 156 specialise its type (ignore the translation this produces)
 157 \item
 158 check that the context produced by this specialisation is empty
 159 \item
 160 get the arguments out of the function type produced from specialising
 161 \item
 162 unify them with the types of the patterns
 163 \item
 164 back substitute with the type of the result of the constructor
 165 \end{itemize}
 166
 167 ToDo: exploit new representation of constructors to make this more
 168 efficient?
 169
 170 \begin{code}
 171 tcPat e pat_in@(ConPatIn name pats)
 172   = let
 173         con_id = lookupE_Value e name
 174     in
 175     tcPats e pats `thenTc` \ (pats', lie, tys) ->
 176
 177     matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
 178
 179     returnTc (ConPat con_id data_ty pats', lie, data_ty)
 180
 181 tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
 182   = let
 183         con_id = lookupE_Value e op
 184     in
 185     tcPats e [pat1, pat2]   `thenTc`    \ ([pat1',pat2'], lie, tys) ->
 186          -- ToDo: there exists a less ugly way, no doubt...
 187
 188     matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty ->
 189
 190     returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty)
 191 \end{code}
 192
 193 %************************************************************************
 194 %*                                                                      *
 195 \subsection{Non-overloaded literals}
 196 %*                                                                      *
 197 %************************************************************************
 198
 199 \begin{code}
 200 tcPat e (LitPatIn lit@(CharLit str))
 201   = returnTc (LitPat lit charTy, nullLIE, charTy)
 202
 203 tcPat e (LitPatIn lit@(StringLit str))
 204   = getSrcLocTc                         `thenNF_Tc` \ loc ->
 205     let
 206         origin = LiteralOrigin lit loc
 207         eq_id  = lookupE_ClassOpByKey e eqClassKey  SLIT("==")
 208     in
 209     newMethod origin eq_id [stringTy]   `thenNF_Tc` \ eq ->
 210     let
 211         comp_op = App (Var (mkInstId eq)) (Lit lit)
 212     in
 213     returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy)
 214
 215 {- OLD:
 216 tcPat e (LitPatIn lit@(StringLit str))
 217   = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy)
 218   where
 219     comp_op   = App (Var eqStringId) (Lit lit)
 220 -}
 221
 222 tcPat e (LitPatIn lit@(IntPrimLit _))
 223   = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy)
 224 tcPat e (LitPatIn lit@(CharPrimLit _))
 225   = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy)
 226 tcPat e (LitPatIn lit@(StringPrimLit _))
 227   = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy)
 228 tcPat e (LitPatIn lit@(FloatPrimLit _))
 229   = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy)
 230 tcPat e (LitPatIn lit@(DoublePrimLit _))
 231   = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy)
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection{Overloaded patterns: int literals and \tr{n+k} patterns}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 tcPat e (LitPatIn lit@(IntLit i))
 242   = getSrcLocTc                         `thenNF_Tc` \ loc ->
 243     let
 244         origin = LiteralOrigin lit loc
 245     in
 246     newPolyTyVarTy                      `thenNF_Tc` \ tyvar_ty ->
 247     let
 248         from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
 249         from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
 250         eq_id        = lookupE_ClassOpByKey e eqClassKey  SLIT("==")
 251     in
 252     newOverloadedLit origin
 253                      (OverloadedIntegral i from_int from_integer)
 254                      tyvar_ty           `thenNF_Tc` \ over_lit ->
 255
 256     newMethod origin eq_id [tyvar_ty]   `thenNF_Tc` \ eq ->
 257
 258     returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
 259                                      (Var (mkInstId over_lit))),
 260               mkLIE [over_lit, eq],
 261               tyvar_ty)
 262
 263 tcPat e (LitPatIn lit@(FracLit f))
 264   = getSrcLocTc                         `thenNF_Tc` \ loc ->
 265     let
 266         origin = LiteralOrigin lit loc
 267     in
 268     newPolyTyVarTy                      `thenNF_Tc` \ tyvar_ty ->
 269     let
 270         eq_id         = lookupE_ClassOpByKey e eqClassKey         SLIT("==")
 271         from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational")
 272     in
 273     newOverloadedLit origin
 274                      (OverloadedFractional f from_rational)
 275                      tyvar_ty           `thenNF_Tc` \ over_lit ->
 276
 277     newMethod origin eq_id [tyvar_ty]   `thenNF_Tc` \ eq ->
 278
 279     returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
 280                                      (Var (mkInstId over_lit))),
 281               mkLIE [over_lit, eq],
 282               tyvar_ty)
 283
 284 tcPat e (LitPatIn lit@(LitLitLitIn s))
 285   = error "tcPat: can't handle ``literal-literal'' patterns"
 286 {-
 287   = getSrcLocTc                         `thenNF_Tc` \ loc ->
 288     let
 289         origin = LiteralOrigin lit loc
 290     in
 291     newPolyTyVarTy                      `thenNF_Tc` \ tyvar_ty ->
 292     let
 293         eq_id = lookupE_ClassOpByKey e eqClassKey "=="
 294     in
 295     newOverloadedLit origin
 296                      (OverloadedLitLit s)
 297                      tyvar_ty           `thenNF_Tc` \ over_lit ->
 298
 299     newMethod origin eq_id [tyvar_ty]   `thenNF_Tc` \ eq ->
 300
 301     returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq))
 302                                      (Var (mkInstId over_lit))),
 303               mkLIE [over_lit, eq],
 304               tyvar_ty)
 305 -}
 306
 307 tcPat e (NPlusKPatIn name lit@(IntLit k))
 308   = getSrcLocTc                         `thenNF_Tc` \ loc ->
 309     let
 310         origin   = LiteralOrigin lit loc
 311
 312         local    = lookupE_Binder e name
 313         local_ty = getIdUniType local
 314
 315         ge_id        = lookupE_ClassOpByKey e ordClassKey SLIT(">=")
 316         minus_id     = lookupE_ClassOpByKey e numClassKey SLIT("-")
 317         from_int     = lookupE_ClassOpByKey e numClassKey SLIT("fromInt")
 318         from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger")
 319     in
 320     newOverloadedLit origin
 321                      (OverloadedIntegral k from_int from_integer)
 322                      local_ty              `thenNF_Tc` \ over_lit ->
 323
 324     newMethod origin ge_id      [local_ty] `thenNF_Tc` \ ge ->
 325     newMethod origin minus_id   [local_ty] `thenNF_Tc` \ minus ->
 326
 327     returnTc (NPlusKPat local lit local_ty
 328                         (Var (mkInstId over_lit))
 329                         (Var (mkInstId ge))
 330                         (Var (mkInstId minus)),
 331               mkLIE [over_lit, ge, minus],
 332               local_ty)
 333
 334 tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit"
 335
 336 #ifdef DPH
 337 tcPat e (ProcessorPatIn pats pat)
 338   = tcPidPats e pats            `thenTc` \ (pats',convs, lie, tys)->
 339     tcPat e pat                 `thenTc` \ (pat', ty, lie') ->
 340     returnTc (ProcessorPat pats' convs pat',
 341               plusLIE lie lie',
 342               mkProcessorTy tys ty)
 343 #endif {- Data Parallel Haskell -}
 344 \end{code}
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection{Lists of patterns}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353 tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType])
 354
 355 tcPats e [] = returnTc ([], nullLIE, [])
 356
 357 tcPats e (pat:pats)
 358   = tcPat e pat                 `thenTc` \ (pat',  lie,  ty)  ->
 359     tcPats e pats               `thenTc` \ (pats', lie', tys) ->
 360
 361     returnTc (pat':pats', plusLIE lie lie', ty:tys)
 362 \end{code}
 363
 364 @matchConArgTys@ grabs the signature of the data constructor, and
 365 unifies the actual args against the expected ones.
 366
 367 \begin{code}
 368 matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType
 369
 370 matchConArgTys con_id arg_tys err_ctxt
 371   = let
 372         no_of_args = length arg_tys
 373         (sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id
 374              -- Ignore the sig_theta; overloaded constructors only
 375              -- behave differently when called, not when used for
 376              -- matching.
 377         con_arity  = length sig_tys
 378     in
 379     getSrcLocTc                         `thenNF_Tc` \ loc ->
 380     checkTc (con_arity /= no_of_args)
 381             (dataConArityErr con_id con_arity no_of_args loc) `thenTc_`
 382
 383     copyTyVars sig_tyvars               `thenNF_Tc` \ (inst_env, _, new_tyvar_tys) ->
 384     let
 385         (_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys
 386     in
 387     unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty)  `thenTc_`
 388     returnTc inst_result_ty
 389 \end{code}