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
|
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
Pattern-matching constructors
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
-- for details
module MatchCon ( matchConFamily ) where
#include "HsVersions.h"
import {-# SOURCE #-} Match ( match )
import HsSyn
import DsBinds
import DataCon
import TcType
import Type
import CoreSyn
import DsMonad
import DsUtils
import Util ( takeList )
import Id
import SrcLoc
import Outputable
\end{code}
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.
\begin{code}
matchConFamily :: [Id]
-> Type
-> [[EquationInfo]]
-> DsM MatchResult
-- Each group of eqns is for a single constructor
matchConFamily (var:vars) ty groups
= do { alts <- mapM (matchOneCon vars ty) groups
; return (mkCoAlgCaseMatchResult var ty alts) }
matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
= do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)
; arg_vars <- selectMatchVars (take (dataConSourceArity con1)
(eqn_pats (head eqns')))
-- Use the new arugment patterns as a source of
-- suggestions for the new variables
; match_result <- match (arg_vars ++ vars) ty eqns'
; return (con1, tvs1 ++ dicts1 ++ arg_vars,
adjustMatchResult (foldr1 (.) wraps) match_result) }
where
ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1,
pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1
arg_tys = dataConInstOrigArgTys con1 inst_tys
inst_tys = tcTyConAppArgs pat_ty1 ++
mkTyVarTys (takeList (dataConExTyVars con1) tvs1)
-- Newtypes opaque, hence tcTyConAppArgs
-- dataConInstOrigArgTys takes the univ and existential tyvars
-- and returns the types of the *value* args, which is what we want
shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args
} : pats })
= do { prs <- dsLHsBinds bind
; return (wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkDsLet (Rec prs),
eqn { eqn_pats = conArgPats con1 arg_tys args ++ pats }) }
conArgPats :: DataCon
-> [Type] -- Instantiated argument types
-- Used only to fill in the types of WildPats, which
-- are probably never looked at anyway
-> HsConDetails (LPat Id) (HsRecFields Id (LPat Id))
-> [Pat Id]
conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps
conArgPats data_con arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
conArgPats data_con arg_tys (RecCon (HsRecFields rpats _))
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
-- fields at all
map WildPat arg_tys
| otherwise
= zipWith mk_pat (dataConFieldLabels data_con) arg_tys
where
-- mk_pat picks a WildPat of the appropriate type for absent fields,
-- and the specified pattern for present fields
mk_pat lbl arg_ty
= case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of
(pat:pats) -> ASSERT( null pats ) unLoc pat
[] -> WildPat arg_ty
\end{code}
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.
|
