summaryrefslogtreecommitdiff
path: root/compiler/deSugar/MatchCon.hs
blob: ce1f19f56011c57dd7eba5564fe84838715c76fa (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Pattern-matching constructors
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module MatchCon ( matchConFamily, matchPatSyn ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-} Match     ( match )

import HsSyn
import DsBinds
import ConLike
import BasicTypes ( Origin(..) )
import TcType
import DsMonad
import DsUtils
import MkCore   ( mkCoreLets )
import Util
import Id
import NameEnv
import FieldLabel ( flSelector )
import SrcLoc
import Outputable
import Control.Monad(liftM)
import Data.List (groupBy)

{-
We are confronted with the first column of patterns in a set of
equations, all beginning with constructors from one ``family'' (e.g.,
@[]@ and @:@ make up the @List@ ``family'').  We want to generate the
alternatives for a @Case@ expression.  There are several choices:
\begin{enumerate}
\item
Generate an alternative for every constructor in the family, whether
they are used in this set of equations or not; this is what the Wadler
chapter does.
\begin{description}
\item[Advantages:]
(a)~Simple.  (b)~It may also be that large sparsely-used constructor
families are mainly handled by the code for literals.
\item[Disadvantages:]
(a)~Not practical for large sparsely-used constructor families, e.g.,
the ASCII character set.  (b)~Have to look up a list of what
constructors make up the whole family.
\end{description}

\item
Generate an alternative for each constructor used, then add a default
alternative in case some constructors in the family weren't used.
\begin{description}
\item[Advantages:]
(a)~Alternatives aren't generated for unused constructors.  (b)~The
STG is quite happy with defaults.  (c)~No lookup in an environment needed.
\item[Disadvantages:]
(a)~A spurious default alternative may be generated.
\end{description}

\item
``Do it right:'' generate an alternative for each constructor used,
and add a default alternative if all constructors in the family
weren't used.
\begin{description}
\item[Advantages:]
(a)~You will get cases with only one alternative (and no default),
which should be amenable to optimisation.  Tuples are a common example.
\item[Disadvantages:]
(b)~Have to look up constructor families in TDE (as above).
\end{description}
\end{enumerate}

We are implementing the ``do-it-right'' option for now.  The arguments
to @matchConFamily@ are the same as to @match@; the extra @Int@
returned is the number of constructors in the family.

The function @matchConFamily@ is concerned with this
have-we-used-all-the-constructors? question; the local function
@match_cons_used@ does all the real work.
-}

matchConFamily :: [Id]
               -> Type
               -> [[EquationInfo]]
               -> DsM MatchResult
-- Each group of eqns is for a single constructor
matchConFamily (var:vars) ty groups
  = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
       return (mkCoAlgCaseMatchResult var ty alts)
  where
    toRealAlt alt = case alt_pat alt of
        RealDataCon dcon -> alt{ alt_pat = dcon }
        _ -> panic "matchConFamily: not RealDataCon"
matchConFamily [] _ _ = panic "matchConFamily []"

matchPatSyn :: [Id]
            -> Type
            -> [EquationInfo]
            -> DsM MatchResult
matchPatSyn (var:vars) ty eqns
  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
       return (mkCoSynCaseMatchResult var ty alt)
  where
    toSynAlt alt = case alt_pat alt of
        PatSynCon psyn -> alt{ alt_pat = psyn }
        _ -> panic "matchPatSyn: not PatSynCon"
matchPatSyn _ _ _ = panic "matchPatSyn []"

type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))

matchOneConLike :: [Id]
                -> Type
                -> [EquationInfo]
                -> DsM (CaseAlt ConLike)
matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
                           -- ex_tvs can only be tyvars as data types in source
                           -- Haskell cannot mention covar yet (Aug 2018).
                         ASSERT( tvs1 `equalLength` ex_tvs )
                         arg_tys ++ mkTyVarTys tvs1

              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
        -- dataConInstOrigArgTys takes the univ and existential tyvars
        -- and returns the types of the *value* args, which is what we want

              match_group :: [Id]
                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
              -- All members of the group have compatible ConArgPats
              match_group arg_vars arg_eqn_prs
                = ASSERT( notNull arg_eqn_prs )
                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'
                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }

              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
                                                             pat_binds = bind, pat_args = args
                                                  } : pats }))
                = do ds_bind <- dsTcEvBinds bind
                     return ( wrapBinds (tvs `zip` tvs1)
                            . wrapBinds (ds  `zip` dicts1)
                            . mkCoreLets ds_bind
                            , eqn { eqn_orig = Generated
                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }
                            )
              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)

        ; arg_vars <- selectConMatchVars val_arg_tys args1
                -- Use the first equation as a source of
                -- suggestions for the new variables

        -- Divide into sub-groups; see Note [Record patterns]
        ; let groups :: [[(ConArgPats, EquationInfo)]]
              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
                                               | eqn <- eqn1:eqns ]

        ; match_results <- mapM (match_group arg_vars) groups

        ; return $ MkCaseAlt{ alt_pat = con1,
                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
                              alt_wrapper = wrapper1,
                              alt_result = foldr1 combineMatchResults match_results } }
  where
    ConPatOut { pat_con = (dL->L _ con1)
              , pat_arg_tys = arg_tys, pat_wrap = wrapper1,
                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
              = firstPat eqn1
    fields1 = map flSelector (conLikeFieldLabels con1)

    ex_tvs = conLikeExTyCoVars con1

    -- Choose the right arg_vars in the right order for this group
    -- Note [Record patterns]
    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
    select_arg_vars arg_vars ((arg_pats, _) : _)
      | RecCon flds <- arg_pats
      , let rpats = rec_flds flds
      , not (null rpats)     -- Treated specially; cf conArgPats
      = ASSERT2( fields1 `equalLength` arg_vars,
                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )
        map lookup_fld rpats
      | otherwise
      = arg_vars
      where
        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
        lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env
                                            (idName (unLoc (hsRecFieldId rpat)))
    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
matchOneConLike _ _ [] = panic "matchOneCon []"

-----------------
compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
-- Two constructors have compatible argument patterns if the number
-- and order of sub-matches is the same in both cases
compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)
compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)
compatible_pats _                 _                 = True -- Prefix or infix con

same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
            -> Bool
same_fields flds1 flds2
  = all2 (\(dL->L _ f1) (dL->L _ f2)
                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
         (rec_flds flds1) (rec_flds flds2)


-----------------
selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys
selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)
selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]

conArgPats :: [Type]      -- Instantiated argument types
                          -- Used only to fill in the types of WildPats, which
                          -- are probably never looked at anyway
           -> ConArgPats
           -> [Pat GhcTc]
conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps
conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
  | null rpats = map WildPat arg_tys
        -- Important special case for C {}, which can be used for a
        -- datacon that isn't declared to have fields at all
  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats

{-
Note [Record patterns]
~~~~~~~~~~~~~~~~~~~~~~
Consider
         data T = T { x,y,z :: Bool }

         f (T { y=True, x=False }) = ...

We must match the patterns IN THE ORDER GIVEN, thus for the first
one we match y=True before x=False.  See #246; or imagine
matching against (T { y=False, x=undefined }): should fail without
touching the undefined.

Now consider:

         f (T { y=True, x=False }) = ...
         f (T { x=True, y= False}) = ...

In the first we must test y first; in the second we must test x
first.  So we must divide even the equations for a single constructor
T into sub-goups, based on whether they match the same field in the
same order.  That's what the (groupBy compatible_pats) grouping.

All non-record patterns are "compatible" in this sense, because the
positional patterns (T a b) and (a `T` b) all match the arguments
in order.  Also T {} is special because it's equivalent to (T _ _).
Hence the (null rpats) checks here and there.


Note [Existentials in shift_con_pat]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
        data T = forall a. Ord a => T a (a->Int)

        f (T x f) True  = ...expr1...
        f (T y g) False = ...expr2..

When we put in the tyvars etc we get

        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...

After desugaring etc we'll get a single case:

        f = \t::T b::Bool ->
            case t of
               T a (d::Ord a) (x::a) (f::a->Int)) ->
            case b of
                True  -> ...expr1...
                False -> ...expr2...

*** We have to substitute [a/b, d/e] in expr2! **
Hence
                False -> ....((/\b\(e:Ord b).expr2) a d)....

Originally I tried to use
        (\b -> let e = d in expr2) a
to do this substitution.  While this is "correct" in a way, it fails
Lint, because e::Ord b but d::Ord a.

-}