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 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module MatchCon ( matchConFamily ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} Match     ( match )
  21
  22 import HsSyn
  23 import DsBinds
  24 import DataCon
  25 import TcType
  26 import Type
  27 import CoreSyn
  28 import MkCore
  29 import DsMonad
  30 import DsUtils
  31 import Util     ( all2, takeList, zipEqual )
  32 import ListSetOps ( runs )
  33 import Id
  34 import Var      ( Var )
  35 import NameEnv
  36 import SrcLoc
  37 import Outputable
  38 \end{code}
  39
  40 We are confronted with the first column of patterns in a set of
  41 equations, all beginning with constructors from one ``family'' (e.g.,
  42 @[]@ and @:@ make up the @List@ ``family'').  We want to generate the
  43 alternatives for a @Case@ expression.  There are several choices:
  44 \begin{enumerate}
  45 \item
  46 Generate an alternative for every constructor in the family, whether
  47 they are used in this set of equations or not; this is what the Wadler
  48 chapter does.
  49 \begin{description}
  50 \item[Advantages:]
  51 (a)~Simple.  (b)~It may also be that large sparsely-used constructor
  52 families are mainly handled by the code for literals.
  53 \item[Disadvantages:]
  54 (a)~Not practical for large sparsely-used constructor families, e.g.,
  55 the ASCII character set.  (b)~Have to look up a list of what
  56 constructors make up the whole family.
  57 \end{description}
  58
  59 \item
  60 Generate an alternative for each constructor used, then add a default
  61 alternative in case some constructors in the family weren't used.
  62 \begin{description}
  63 \item[Advantages:]
  64 (a)~Alternatives aren't generated for unused constructors.  (b)~The
  65 STG is quite happy with defaults.  (c)~No lookup in an environment needed.
  66 \item[Disadvantages:]
  67 (a)~A spurious default alternative may be generated.
  68 \end{description}
  69
  70 \item
  71 ``Do it right:'' generate an alternative for each constructor used,
  72 and add a default alternative if all constructors in the family
  73 weren't used.
  74 \begin{description}
  75 \item[Advantages:]
  76 (a)~You will get cases with only one alternative (and no default),
  77 which should be amenable to optimisation.  Tuples are a common example.
  78 \item[Disadvantages:]
  79 (b)~Have to look up constructor families in TDE (as above).
  80 \end{description}
  81 \end{enumerate}
  82
  83 We are implementing the ``do-it-right'' option for now.  The arguments
  84 to @matchConFamily@ are the same as to @match@; the extra @Int@
  85 returned is the number of constructors in the family.
  86
  87 The function @matchConFamily@ is concerned with this
  88 have-we-used-all-the-constructors? question; the local function
  89 @match_cons_used@ does all the real work.
  90 \begin{code}
  91 matchConFamily :: [Id]
  92                -> Type
  93                -> [[EquationInfo]]
  94                -> DsM MatchResult
  95 -- Each group of eqns is for a single constructor
  96 matchConFamily (var:vars) ty groups
  97   = do  { alts <- mapM (matchOneCon vars ty) groups
  98         ; return (mkCoAlgCaseMatchResult var ty alts) }
  99
 100 type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))
 101
 102 matchOneCon :: [Id]
 103             -> Type
 104             -> [EquationInfo]
 105             -> DsM (DataCon, [Var], MatchResult)
 106 matchOneCon vars ty (eqn1 : eqns)       -- All eqns for a single constructor
 107   = do  { arg_vars <- selectConMatchVars arg_tys args1
 108                 -- Use the first equation as a source of
 109                 -- suggestions for the new variables
 110
 111         -- Divide into sub-groups; see Note [Record patterns]
 112         ; let groups :: [[(ConArgPats, EquationInfo)]]
 113               groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn)
 114                                             | eqn <- eqn1:eqns ]
 115
 116         ; match_results <- mapM (match_group arg_vars) groups
 117
 118         ; return (con1, tvs1 ++ dicts1 ++ arg_vars,
 119                   foldr1 combineMatchResults match_results) }
 120   where
 121     ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1,
 122                 pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
 123               = firstPat eqn1
 124     fields1 = dataConFieldLabels con1
 125
 126     arg_tys  = dataConInstOrigArgTys con1 inst_tys
 127     inst_tys = tcTyConAppArgs pat_ty1 ++
 128                mkTyVarTys (takeList (dataConExTyVars con1) tvs1)
 129         -- Newtypes opaque, hence tcTyConAppArgs
 130         -- dataConInstOrigArgTys takes the univ and existential tyvars
 131         -- and returns the types of the *value* args, which is what we want
 132
 133     match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
 134     -- All members of the group have compatible ConArgPats
 135     match_group arg_vars arg_eqn_prs
 136       = do { (wraps, eqns') <- mapAndUnzipM shift arg_eqn_prs
 137            ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
 138            ; match_result <- match (group_arg_vars ++ vars) ty eqns'
 139            ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
 140
 141     shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
 142                                                    pat_binds = bind, pat_args = args
 143                                         } : pats }))
 144       = do { prs <- dsLHsBinds bind
 145            ; return (wrapBinds (tvs `zip` tvs1)
 146                     . wrapBinds (ds  `zip` dicts1)
 147                     . mkCoreLet (Rec prs),
 148                     eqn { eqn_pats = conArgPats arg_tys args ++ pats }) }
 149
 150     -- Choose the right arg_vars in the right order for this group
 151     -- Note [Record patterns]
 152     select_arg_vars arg_vars ((arg_pats, _) : _)
 153       | RecCon flds <- arg_pats
 154       , let rpats = rec_flds flds
 155       , not (null rpats)     -- Treated specially; cf conArgPats
 156       = ASSERT2( length fields1 == length arg_vars,
 157                  ppr con1 $$ ppr fields1 $$ ppr arg_vars )
 158         map lookup_fld rpats
 159       | otherwise
 160       = arg_vars
 161       where
 162         fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
 163         lookup_fld rpat = lookupNameEnv_NF fld_var_env
 164                                            (idName (unLoc (hsRecFieldId rpat)))
 165
 166 -----------------
 167 compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
 168 -- Two constructors have compatible argument patterns if the number
 169 -- and order of sub-matches is the same in both cases
 170 compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
 171 compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)
 172 compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)
 173 compatible_pats _                 _                 = True -- Prefix or infix con
 174
 175 same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
 176 same_fields flds1 flds2
 177   = all2 (\f1 f2 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
 178          (rec_flds flds1) (rec_flds flds2)
 179
 180
 181 -----------------
 182 selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
 183 selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDs arg_tys
 184 selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)
 185 selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
 186
 187 conArgPats :: [Type]    -- Instantiated argument types
 188                         -- Used only to fill in the types of WildPats, which
 189                         -- are probably never looked at anyway
 190            -> ConArgPats
 191            -> [Pat Id]
 192 conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps
 193 conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
 194 conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
 195   | null rpats = map WildPat arg_tys
 196         -- Important special case for C {}, which can be used for a
 197         -- datacon that isn't declared to have fields at all
 198   | otherwise  = map (unLoc . hsRecFieldArg) rpats
 199 \end{code}
 200
 201 Note [Record patterns]
 202 ~~~~~~~~~~~~~~~~~~~~~~
 203 Consider
 204          data T = T { x,y,z :: Bool }
 205
 206          f (T { y=True, x=False }) = ...
 207
 208 We must match the patterns IN THE ORDER GIVEN, thus for the first
 209 one we match y=True before x=False.  See Trac #246; or imagine
 210 matching against (T { y=False, x=undefined }): should fail without
 211 touching the undefined.
 212
 213 Now consider:
 214
 215          f (T { y=True, x=False }) = ...
 216          f (T { x=True, y= False}) = ...
 217
 218 In the first we must test y first; in the second we must test x
 219 first.  So we must divide even the equations for a single constructor
 220 T into sub-goups, based on whether they match the same field in the
 221 same order.  That's what the (runs compatible_pats) grouping.
 222
 223 All non-record patterns are "compatible" in this sense, because the
 224 positional patterns (T a b) and (a `T` b) all match the arguments
 225 in order.  Also T {} is special because it's equivalent to (T _ _).
 226 Hence the (null rpats) checks here and there.
 227
 228
 229 Note [Existentials in shift_con_pat]
 230 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 231 Consider
 232         data T = forall a. Ord a => T a (a->Int)
 233
 234         f (T x f) True  = ...expr1...
 235         f (T y g) False = ...expr2..
 236
 237 When we put in the tyvars etc we get
 238
 239         f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
 240         f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
 241
 242 After desugaring etc we'll get a single case:
 243
 244         f = \t::T b::Bool ->
 245             case t of
 246                T a (d::Ord a) (x::a) (f::a->Int)) ->
 247             case b of
 248                 True  -> ...expr1...
 249                 False -> ...expr2...
 250
 251 *** We have to substitute [a/b, d/e] in expr2! **
 252 Hence
 253                 False -> ....((/\b\(e:Ord b).expr2) a d)....
 254
 255 Originally I tried to use
 256         (\b -> let e = d in expr2) a
 257 to do this substitution.  While this is "correct" in a way, it fails
 258 Lint, because e::Ord b but d::Ord a.
 259