MatchCon.lhs 5.69 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2
%
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Pattern-matching constructors
7 8

\begin{code}
9 10
module MatchCon ( matchConFamily ) where

11 12 13
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
15 16 17 18 19
import HsSyn
import DsBinds
import DataCon
import TcType
import Type
20
import CoreSyn
21
import DsMonad
22
import DsUtils
23
import Util	( takeList )
Simon Marlow's avatar
Simon Marlow committed
24 25
import Id
import SrcLoc
26
import Outputable
27
\end{code}
28 29 30 31

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
32
alternatives for a @Case@ expression.  There are several choices:
33 34 35 36 37 38 39
\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:]
40 41
(a)~Simple.  (b)~It may also be that large sparsely-used constructor
families are mainly handled by the code for literals.
42
\item[Disadvantages:]
43 44 45
(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.
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
\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}

72 73 74
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.
75 76

The function @matchConFamily@ is concerned with this
77
have-we-used-all-the-constructors? question; the local function
78 79 80
@match_cons_used@ does all the real work.
\begin{code}
matchConFamily :: [Id]
81
               -> Type
82
	       -> [[EquationInfo]]
83
	       -> DsM MatchResult
84 85 86 87 88 89 90
-- 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)
91
	; arg_vars <- selectMatchVars (take (dataConSourceArity con1) 
92 93 94
					    (eqn_pats (head eqns')))
		-- Use the new arugment patterns as a source of 
		-- suggestions for the new variables
95
	; match_result <- match (arg_vars ++ vars) ty eqns'
96
      	; return (con1, tvs1 ++ dicts1 ++ arg_vars, 
97
		  adjustMatchResult (foldr1 (.) wraps) match_result) }
98
  where
99
    ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1,
100 101
	        pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1
	
102 103 104
    arg_tys  = dataConInstOrigArgTys con1 inst_tys
    inst_tys = tcTyConAppArgs pat_ty1 ++ 
	       mkTyVarTys (takeList (dataConExTyVars con1) tvs1)
105
	-- Newtypes opaque, hence tcTyConAppArgs
106 107
	-- dataConInstOrigArgTys takes the univ and existential tyvars
	-- and returns the types of the *value* args, which is what we want
108 109 110 111

    shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, 
					       pat_binds = bind, pat_args = args
					      } : pats })
112
	= do { prs <- dsLHsBinds bind
113 114 115
	     ; return (wrapBinds (tvs `zip` tvs1) 
		       . wrapBinds (ds  `zip` dicts1)
		       . mkDsLet (Rec prs),
116
		       eqn { eqn_pats = conArgPats con1 arg_tys args ++ pats }) }
117 118 119

conArgPats :: DataCon 
	   -> [Type]	-- Instantiated argument types 
120 121
			-- Used only to fill in the types of WildPats, which
			-- are probably never looked at anyway
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
	   -> HsConDetails 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 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
139
	= case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of
140 141
	    (pat:pats) -> ASSERT( null pats ) unLoc pat
	    []	       -> WildPat arg_ty
142 143
\end{code}

144 145
Note [Existentials in shift_con_pat]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146 147 148 149 150 151 152 153 154
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...
155
	f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
156 157 158 159 160 161 162 163 164 165 166

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! **
167 168
Hence
		False -> ....((/\b\(e:Ord b).expr2) a d)....
169 170 171 172 173 174

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.