compiler/deSugar/MatchCon.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Pattern-matching constructors
   7
   8 \begin{code}
   9 module MatchCon ( matchConFamily ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} Match     ( match )
  14
  15 import HsSyn
  16 import DsBinds
  17 import DataCon
  18 import TcType
  19 import Type
  20 import CoreSyn
  21 import DsMonad
  22 import DsUtils
  23
  24 import Id
  25 import SrcLoc
  26 import Outputable
  27 \end{code}
  28
  29 We are confronted with the first column of patterns in a set of
  30 equations, all beginning with constructors from one ``family'' (e.g.,
  31 @[]@ and @:@ make up the @List@ ``family'').  We want to generate the
  32 alternatives for a @Case@ expression.  There are several choices:
  33 \begin{enumerate}
  34 \item
  35 Generate an alternative for every constructor in the family, whether
  36 they are used in this set of equations or not; this is what the Wadler
  37 chapter does.
  38 \begin{description}
  39 \item[Advantages:]
  40 (a)~Simple.  (b)~It may also be that large sparsely-used constructor
  41 families are mainly handled by the code for literals.
  42 \item[Disadvantages:]
  43 (a)~Not practical for large sparsely-used constructor families, e.g.,
  44 the ASCII character set.  (b)~Have to look up a list of what
  45 constructors make up the whole family.
  46 \end{description}
  47
  48 \item
  49 Generate an alternative for each constructor used, then add a default
  50 alternative in case some constructors in the family weren't used.
  51 \begin{description}
  52 \item[Advantages:]
  53 (a)~Alternatives aren't generated for unused constructors.  (b)~The
  54 STG is quite happy with defaults.  (c)~No lookup in an environment needed.
  55 \item[Disadvantages:]
  56 (a)~A spurious default alternative may be generated.
  57 \end{description}
  58
  59 \item
  60 ``Do it right:'' generate an alternative for each constructor used,
  61 and add a default alternative if all constructors in the family
  62 weren't used.
  63 \begin{description}
  64 \item[Advantages:]
  65 (a)~You will get cases with only one alternative (and no default),
  66 which should be amenable to optimisation.  Tuples are a common example.
  67 \item[Disadvantages:]
  68 (b)~Have to look up constructor families in TDE (as above).
  69 \end{description}
  70 \end{enumerate}
  71
  72 We are implementing the ``do-it-right'' option for now.  The arguments
  73 to @matchConFamily@ are the same as to @match@; the extra @Int@
  74 returned is the number of constructors in the family.
  75
  76 The function @matchConFamily@ is concerned with this
  77 have-we-used-all-the-constructors? question; the local function
  78 @match_cons_used@ does all the real work.
  79 \begin{code}
  80 matchConFamily :: [Id]
  81                -> Type
  82                -> [[EquationInfo]]
  83                -> DsM MatchResult
  84 -- Each group of eqns is for a single constructor
  85 matchConFamily (var:vars) ty groups
  86   = do  { alts <- mapM (matchOneCon vars ty) groups
  87         ; return (mkCoAlgCaseMatchResult var ty alts) }
  88
  89 matchOneCon vars ty (eqn1 : eqns)       -- All eqns for a single constructor
  90   = do  { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)
  91         ; arg_vars <- selectMatchVars (take (dataConSourceArity con)
  92                                             (eqn_pats (head eqns')))
  93                 -- Use the new arugment patterns as a source of
  94                 -- suggestions for the new variables
  95         ; match_result <- match (arg_vars ++ vars) ty eqns'
  96         ; return (con, tvs1 ++ dicts1 ++ arg_vars,
  97                   adjustMatchResult (foldr1 (.) wraps) match_result) }
  98   where
  99     ConPatOut { pat_con = L _ con, pat_ty = pat_ty1,
 100                 pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1
 101
 102     arg_tys  = dataConInstOrigArgTys con inst_tys
 103     n_co_args = length (dataConEqSpec con)
 104     inst_tys = tcTyConAppArgs pat_ty1 ++ (drop n_co_args $ mkTyVarTys tvs1)
 105         -- Newtypes opaque, hence tcTyConAppArgs
 106
 107     shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
 108                                                pat_binds = bind, pat_args = args
 109                                               } : pats })
 110         = do { prs <- dsLHsBinds bind
 111              ; return (wrapBinds (tvs `zip` tvs1)
 112                        . wrapBinds (ds  `zip` dicts1)
 113                        . mkDsLet (Rec prs),
 114                        eqn { eqn_pats = conArgPats con arg_tys args ++ pats }) }
 115
 116 conArgPats :: DataCon
 117            -> [Type]    -- Instantiated argument types
 118            -> HsConDetails Id (LPat Id)
 119            -> [Pat Id]
 120 conArgPats data_con arg_tys (PrefixCon ps)   = map unLoc ps
 121 conArgPats data_con arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
 122 conArgPats data_con arg_tys (RecCon rpats)
 123   | null rpats
 124   =     -- Special case for C {}, which can be used for
 125         -- a constructor that isn't declared to have
 126         -- fields at all
 127     map WildPat arg_tys
 128
 129   | otherwise
 130   = zipWith mk_pat (dataConFieldLabels data_con) arg_tys
 131   where
 132         -- mk_pat picks a WildPat of the appropriate type for absent fields,
 133         -- and the specified pattern for present fields
 134     mk_pat lbl arg_ty
 135         = case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of
 136             (pat:pats) -> ASSERT( null pats ) unLoc pat
 137             []         -> WildPat arg_ty
 138 \end{code}
 139
 140 Note [Existentials in shift_con_pat]
 141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 142 Consider
 143         data T = forall a. Ord a => T a (a->Int)
 144
 145         f (T x f) True  = ...expr1...
 146         f (T y g) False = ...expr2..
 147
 148 When we put in the tyvars etc we get
 149
 150         f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
 151         f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
 152
 153 After desugaring etc we'll get a single case:
 154
 155         f = \t::T b::Bool ->
 156             case t of
 157                T a (d::Ord a) (x::a) (f::a->Int)) ->
 158             case b of
 159                 True  -> ...expr1...
 160                 False -> ...expr2...
 161
 162 *** We have to substitute [a/b, d/e] in expr2! **
 163 Hence
 164                 False -> ....((/\b\(e:Ord b).expr2) a d)....
 165
 166 Originally I tried to use
 167         (\b -> let e = d in expr2) a
 168 to do this substitution.  While this is "correct" in a way, it fails
 169 Lint, because e::Ord b but d::Ord a.
 170