MatchCon.lhs 6.19 KB
 Simon Marlow committed Oct 11, 2006 1 2 % % (c) The University of Glasgow 2006  simonm committed Dec 02, 1998 3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  partain committed Jan 08, 1996 4 %  Simon Marlow committed Oct 11, 2006 5 6  Pattern-matching constructors  partain committed Jan 08, 1996 7 8  \begin{code}  twanvl committed Feb 03, 2008 9 {-# OPTIONS -fno-warn-incomplete-patterns #-}  Ian Lynagh committed Sep 01, 2007 10 11 12 -- 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  Ian Lynagh committed Sep 04, 2007 13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings  Ian Lynagh committed Sep 01, 2007 14 15 -- for details  partain committed Mar 19, 1996 16 17 module MatchCon ( matchConFamily ) where  simonm committed Jan 08, 1998 18 19 20 #include "HsVersions.h" import {-# SOURCE #-} Match ( match )  partain committed Mar 19, 1996 21   Simon Marlow committed Oct 11, 2006 22 23 24 25 26 import HsSyn import DsBinds import DataCon import TcType import Type  simonpj committed Sep 30, 2004 27 import CoreSyn  batterseapower committed Jul 31, 2008 28 import MkCore  partain committed Mar 19, 1996 29 import DsMonad  partain committed Jan 08, 1996 30 import DsUtils  David Himmelstrup committed Jun 07, 2007 31 import Util ( takeList )  Simon Marlow committed Oct 11, 2006 32 import Id  twanvl committed Feb 03, 2008 33 import Var (TyVar)  Simon Marlow committed Oct 11, 2006 34 import SrcLoc  simonpj committed Sep 30, 2004 35 import Outputable  partain committed Mar 19, 1996 36 \end{code}  partain committed Jan 08, 1996 37 38 39 40  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  partain committed Mar 19, 1996 41 alternatives for a @Case@ expression. There are several choices:  partain committed Jan 08, 1996 42 43 44 45 46 47 48 \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:]  partain committed Mar 19, 1996 49 50 (a)~Simple. (b)~It may also be that large sparsely-used constructor families are mainly handled by the code for literals.  partain committed Jan 08, 1996 51 \item[Disadvantages:]  partain committed Mar 19, 1996 52 53 54 (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.  partain committed Jan 08, 1996 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 \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}  partain committed Mar 19, 1996 81 82 83 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.  partain committed Jan 08, 1996 84 85  The function @matchConFamily@ is concerned with this  partain committed Mar 19, 1996 86 have-we-used-all-the-constructors? question; the local function  partain committed Jan 08, 1996 87 88 89 @match_cons_used@ does all the real work. \begin{code} matchConFamily :: [Id]  simonpj committed Sep 30, 2004 90  -> Type  chak@cse.unsw.edu.au. committed Aug 04, 2006 91  -> [[EquationInfo]]  partain committed Jan 08, 1996 92  -> DsM MatchResult  chak@cse.unsw.edu.au. committed Aug 04, 2006 93 94 95 96 97 -- 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) }  twanvl committed Feb 03, 2008 98 99 100 101 matchOneCon :: [Id] -> Type -> [EquationInfo] -> DsM (DataCon, [TyVar], MatchResult)  chak@cse.unsw.edu.au. committed Aug 04, 2006 102 103 matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor = do { (wraps, eqns') <- mapAndUnzipM shift (eqn1:eqns)  David Himmelstrup committed Jun 07, 2007 104  ; arg_vars <- selectMatchVars (take (dataConSourceArity con1)  chak@cse.unsw.edu.au. committed Aug 04, 2006 105 106 107  (eqn_pats (head eqns'))) -- Use the new arugment patterns as a source of -- suggestions for the new variables  simonpj committed Mar 01, 2005 108  ; match_result <- match (arg_vars ++ vars) ty eqns'  David Himmelstrup committed Jun 07, 2007 109  ; return (con1, tvs1 ++ dicts1 ++ arg_vars,  chak@cse.unsw.edu.au. committed Aug 04, 2006 110  adjustMatchResult (foldr1 (.) wraps) match_result) }  partain committed Jan 08, 1996 111  where  David Himmelstrup committed Jun 07, 2007 112  ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1,  chak@cse.unsw.edu.au. committed Aug 04, 2006 113 114  pat_tvs = tvs1, pat_dicts = dicts1 } = firstPat eqn1  David Himmelstrup committed Jun 07, 2007 115 116 117  arg_tys = dataConInstOrigArgTys con1 inst_tys inst_tys = tcTyConAppArgs pat_ty1 ++ mkTyVarTys (takeList (dataConExTyVars con1) tvs1)  chak@cse.unsw.edu.au. committed Aug 04, 2006 118  -- Newtypes opaque, hence tcTyConAppArgs  David Himmelstrup committed Jun 07, 2007 119 120  -- dataConInstOrigArgTys takes the univ and existential tyvars -- and returns the types of the *value* args, which is what we want  chak@cse.unsw.edu.au. committed Aug 04, 2006 121 122 123 124  shift eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, pat_binds = bind, pat_args = args } : pats })  simonpj committed Jul 19, 2005 125  = do { prs <- dsLHsBinds bind  chak@cse.unsw.edu.au. committed Aug 04, 2006 126 127  ; return (wrapBinds (tvs zip tvs1) . wrapBinds (ds zip dicts1)  batterseapower committed Jul 31, 2008 128  . mkCoreLet (Rec prs),  David Himmelstrup committed Jun 07, 2007 129  eqn { eqn_pats = conArgPats con1 arg_tys args ++ pats }) }  chak@cse.unsw.edu.au. committed Aug 04, 2006 130 131 132  conArgPats :: DataCon -> [Type] -- Instantiated argument types  David Himmelstrup committed Jun 07, 2007 133 134  -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway  David Himmelstrup committed Jun 21, 2007 135  -> HsConDetails (LPat Id) (HsRecFields Id (LPat Id))  chak@cse.unsw.edu.au. committed Aug 04, 2006 136  -> [Pat Id]  twanvl committed Feb 03, 2008 137 138 139 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 _))  chak@cse.unsw.edu.au. committed Aug 04, 2006 140 141 142 143 144 145 146 147 148 149 150 151  | 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  davve@dtek.chalmers.se committed Oct 05, 2006 152  = case [ pat | HsRecField sel_id pat _ <- rpats, idName (unLoc sel_id) == lbl ] of  chak@cse.unsw.edu.au. committed Aug 04, 2006 153 154  (pat:pats) -> ASSERT( null pats ) unLoc pat [] -> WildPat arg_ty  partain committed Jan 08, 1996 155 156 \end{code}  simonpj committed Sep 30, 2004 157 158 Note [Existentials in shift_con_pat] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj committed Feb 14, 2002 159 160 161 162 163 164 165 166 167 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...  simonpj committed Sep 30, 2004 168  f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...  simonpj committed Feb 14, 2002 169 170 171 172 173 174 175 176 177 178 179  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! **  simonpj committed Sep 30, 2004 180 181 Hence False -> ....((/\b\(e:Ord b).expr2) a d)....  simonpj committed Feb 14, 2002 182 183 184 185 186 187  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.