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