4a7d1cd2b7459c352b438cc8318afb7df7b295cb
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Pattern-matching constructors
7 -}
9 {-# LANGUAGE CPP #-}
11 module MatchCon ( matchConFamily, matchPatSyn ) where
13 #include "HsVersions.h"
15 import {-# SOURCE #-} Match ( match )
17 import HsSyn
18 import DsBinds
19 import ConLike
20 import TcType
22 import DsUtils
23 import MkCore ( mkCoreLets )
24 import Util
25 import ListSetOps ( runs )
26 import Id
27 import NameEnv
28 import FieldLabel ( flSelector )
29 import SrcLoc
30 import DynFlags
31 import Outputable
34 {-
35 We are confronted with the first column of patterns in a set of
36 equations, all beginning with constructors from one family'' (e.g.,
37 @[]@ and @:@ make up the @List@ family''). We want to generate the
38 alternatives for a @Case@ expression. There are several choices:
39 \begin{enumerate}
40 \item
41 Generate an alternative for every constructor in the family, whether
42 they are used in this set of equations or not; this is what the Wadler
43 chapter does.
44 \begin{description}
46 (a)~Simple. (b)~It may also be that large sparsely-used constructor
47 families are mainly handled by the code for literals.
49 (a)~Not practical for large sparsely-used constructor families, e.g.,
50 the ASCII character set. (b)~Have to look up a list of what
51 constructors make up the whole family.
52 \end{description}
54 \item
55 Generate an alternative for each constructor used, then add a default
56 alternative in case some constructors in the family weren't used.
57 \begin{description}
59 (a)~Alternatives aren't generated for unused constructors. (b)~The
60 STG is quite happy with defaults. (c)~No lookup in an environment needed.
62 (a)~A spurious default alternative may be generated.
63 \end{description}
65 \item
66 Do it right:'' generate an alternative for each constructor used,
67 and add a default alternative if all constructors in the family
68 weren't used.
69 \begin{description}
71 (a)~You will get cases with only one alternative (and no default),
72 which should be amenable to optimisation. Tuples are a common example.
74 (b)~Have to look up constructor families in TDE (as above).
75 \end{description}
76 \end{enumerate}
78 We are implementing the do-it-right'' option for now. The arguments
79 to @matchConFamily@ are the same as to @match@; the extra @Int@
80 returned is the number of constructors in the family.
82 The function @matchConFamily@ is concerned with this
83 have-we-used-all-the-constructors? question; the local function
84 @match_cons_used@ does all the real work.
85 -}
87 matchConFamily :: [Id]
88 -> Type
89 -> [[EquationInfo]]
90 -> DsM MatchResult
91 -- Each group of eqns is for a single constructor
92 matchConFamily (var:vars) ty groups
93 = do dflags <- getDynFlags
94 alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
95 return (mkCoAlgCaseMatchResult dflags var ty alts)
96 where
97 toRealAlt alt = case alt_pat alt of
98 RealDataCon dcon -> alt{ alt_pat = dcon }
99 _ -> panic "matchConFamily: not RealDataCon"
100 matchConFamily [] _ _ = panic "matchConFamily []"
102 matchPatSyn :: [Id]
103 -> Type
104 -> [EquationInfo]
105 -> DsM MatchResult
106 matchPatSyn (var:vars) ty eqns
107 = do alt <- fmap toSynAlt $matchOneConLike vars ty eqns 108 return (mkCoSynCaseMatchResult var ty alt) 109 where 110 toSynAlt alt = case alt_pat alt of 111 PatSynCon psyn -> alt{ alt_pat = psyn } 112 _ -> panic "matchPatSyn: not PatSynCon" 113 matchPatSyn _ _ _ = panic "matchPatSyn []" 115 type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) 117 matchOneConLike :: [Id] 118 -> Type 119 -> [EquationInfo] 120 -> DsM (CaseAlt ConLike) 121 matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor 122 = do { let inst_tys = ASSERT( tvs1 equalLength ex_tvs ) 123 arg_tys ++ mkTyVarTys tvs1 125 val_arg_tys = conLikeInstOrigArgTys con1 inst_tys 126 -- dataConInstOrigArgTys takes the univ and existential tyvars 127 -- and returns the types of the *value* args, which is what we want 129 match_group :: [Id] 130 -> [(ConArgPats, EquationInfo)] -> DsM MatchResult 131 -- All members of the group have compatible ConArgPats 132 match_group arg_vars arg_eqn_prs 133 = ASSERT( notNull arg_eqn_prs ) 134 do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) 135 ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs 136 ; match_result <- match (group_arg_vars ++ vars) ty eqns' 137 ; return (adjustMatchResult (foldr1 (.) wraps) match_result) } 139 shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, 140 pat_binds = bind, pat_args = args 141 } : pats })) 142 = do ds_bind <- dsTcEvBinds bind 143 return ( wrapBinds (tvs zip tvs1) 144 . wrapBinds (ds zip dicts1) 145 . mkCoreLets ds_bind 146 , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats } 147 ) 148 shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) 150 ; arg_vars <- selectConMatchVars val_arg_tys args1 151 -- Use the first equation as a source of 152 -- suggestions for the new variables 154 -- Divide into sub-groups; see Note [Record patterns] 155 ; let groups :: [[(ConArgPats, EquationInfo)]] 156 groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn) 157 | eqn <- eqn1:eqns ] 159 ; match_results <- mapM (match_group arg_vars) groups 161 ; return$ MkCaseAlt{ alt_pat = con1,
162 alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
163 alt_wrapper = wrapper1,
164 alt_result = foldr1 combineMatchResults match_results } }
165 where
166 ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
167 pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
168 = firstPat eqn1
169 fields1 = map flSelector (conLikeFieldLabels con1)
171 ex_tvs = conLikeExTyVars con1
173 -- Choose the right arg_vars in the right order for this group
174 -- Note [Record patterns]
175 select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
176 select_arg_vars arg_vars ((arg_pats, _) : _)
177 | RecCon flds <- arg_pats
178 , let rpats = rec_flds flds
179 , not (null rpats) -- Treated specially; cf conArgPats
180 = ASSERT2( length fields1 == length arg_vars,
181 ppr con1 $$ppr fields1$$ ppr arg_vars )
182 map lookup_fld rpats
183 | otherwise
184 = arg_vars
185 where
186 fld_var_env = mkNameEnv \$ zipEqual "get_arg_vars" fields1 arg_vars
187 lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
188 (idName (unLoc (hsRecFieldId rpat)))
189 select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
190 matchOneConLike _ _ [] = panic "matchOneCon []"
192 -----------------
193 compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
194 -- Two constructors have compatible argument patterns if the number
195 -- and order of sub-matches is the same in both cases
196 compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
197 compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1)
198 compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2)
199 compatible_pats _ _ = True -- Prefix or infix con
201 same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool
202 same_fields flds1 flds2
203 = all2 (\(L _ f1) (L _ f2)
204 -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
205 (rec_flds flds1) (rec_flds flds2)
208 -----------------
209 selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
210 selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys
211 selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps)
212 selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
214 conArgPats :: [Type] -- Instantiated argument types
215 -- Used only to fill in the types of WildPats, which
216 -- are probably never looked at anyway
217 -> ConArgPats
218 -> [Pat Id]
219 conArgPats _arg_tys (PrefixCon ps) = map unLoc ps
220 conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
221 conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
222 | null rpats = map WildPat arg_tys
223 -- Important special case for C {}, which can be used for a
224 -- datacon that isn't declared to have fields at all
225 | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats
227 {-
228 Note [Record patterns]
229 ~~~~~~~~~~~~~~~~~~~~~~
230 Consider
231 data T = T { x,y,z :: Bool }
233 f (T { y=True, x=False }) = ...
235 We must match the patterns IN THE ORDER GIVEN, thus for the first
236 one we match y=True before x=False. See Trac #246; or imagine
237 matching against (T { y=False, x=undefined }): should fail without
238 touching the undefined.
240 Now consider:
242 f (T { y=True, x=False }) = ...
243 f (T { x=True, y= False}) = ...
245 In the first we must test y first; in the second we must test x
246 first. So we must divide even the equations for a single constructor
247 T into sub-goups, based on whether they match the same field in the
248 same order. That's what the (runs compatible_pats) grouping.
250 All non-record patterns are "compatible" in this sense, because the
251 positional patterns (T a b) and (a T b) all match the arguments
252 in order. Also T {} is special because it's equivalent to (T _ _).
253 Hence the (null rpats) checks here and there.
256 Note [Existentials in shift_con_pat]
257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
258 Consider
259 data T = forall a. Ord a => T a (a->Int)
261 f (T x f) True = ...expr1...
262 f (T y g) False = ...expr2..
264 When we put in the tyvars etc we get
266 f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...
267 f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...
269 After desugaring etc we'll get a single case:
271 f = \t::T b::Bool ->
272 case t of
273 T a (d::Ord a) (x::a) (f::a->Int)) ->
274 case b of
275 True -> ...expr1...
276 False -> ...expr2...
278 *** We have to substitute [a/b, d/e] in expr2! **
279 Hence
280 False -> ....((/\b\(e:Ord b).expr2) a d)....
282 Originally I tried to use
283 (\b -> let e = d in expr2) a
284 to do this substitution. While this is "correct" in a way, it fails
285 Lint, because e::Ord b but d::Ord a.
287 -}