MatchLit.lhs 10.4 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
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 literal patterns
7 8

\begin{code}
9 10
module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
		  tidyLitPat, tidyNPat, 
11
		  matchLiterals, matchNPlusKPats, matchNPats ) where
12

13 14 15
#include "HsVersions.h"

import {-# SOURCE #-} Match  ( match )
sof's avatar
sof committed
16
import {-# SOURCE #-} DsExpr ( dsExpr )
17

18
import DsMonad
19
import DsUtils
20

21
import HsSyn
22

Simon Marlow's avatar
Simon Marlow committed
23
import Id
24
import CoreSyn
25
import MkCore
Simon Marlow's avatar
Simon Marlow committed
26 27
import TyCon
import DataCon
28
import TcHsSyn	( shortCutLit )
Simon Marlow's avatar
Simon Marlow committed
29 30 31 32 33 34 35 36
import TcType
import Type
import PrelNames
import TysWiredIn
import Unique
import Literal
import SrcLoc
import Ratio
37
import Outputable
Simon Marlow's avatar
Simon Marlow committed
38 39
import Util
import FastString
40 41
\end{code}

42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
%************************************************************************
%*									*
		Desugaring literals
	[used to be in DsExpr, but DsMeta needs it,
	 and it's nice to avoid a loop]
%*									*
%************************************************************************

We give int/float literals type @Integer@ and @Rational@, respectively.
The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
around them.

ToDo: put in range checks for when converting ``@i@''
(or should that be in the typechecker?)

For numeric literals, we try to detect there use at a standard type
(@Int@, @Float@, etc.) are directly put in the right constructor.
[NB: down with the @App@ conversion.]

See also below where we look for @DictApps@ for \tr{plusInt}, etc.

\begin{code}
dsLit :: HsLit -> DsM CoreExpr
65 66 67 68 69 70
dsLit (HsStringPrim s) = return (Lit (MachStr s))
dsLit (HsCharPrim   c) = return (Lit (MachChar c))
dsLit (HsIntPrim    i) = return (Lit (MachInt i))
dsLit (HsWordPrim   w) = return (Lit (MachWord w))
dsLit (HsFloatPrim  f) = return (Lit (MachFloat f))
dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
71

72
dsLit (HsChar c)       = return (mkCharExpr c)
73
dsLit (HsString str)   = mkStringExprFS str
74
dsLit (HsInteger i _)  = mkIntegerExpr i
75
dsLit (HsInt i)	       = return (mkIntExpr i)
76

77 78 79 80
dsLit (HsRat r ty) = do
   num   <- mkIntegerExpr (numerator r)
   denom <- mkIntegerExpr (denominator r)
   return (mkConApp ratio_data_con [Type integer_ty, num, denom])
81 82
  where
    (ratio_data_con, integer_ty) 
83 84 85
        = case tcSplitTyConApp ty of
                (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
                                   (head (tyConDataCons tycon), i_ty)
Ian Lynagh's avatar
Ian Lynagh committed
86
                x -> pprPanic "dsLit" (ppr x)
87 88 89 90

dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains 
-- (an expression for) the literal value itself
91 92 93 94 95
dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable 
		   , ol_witness = witness, ol_type = ty })
  | not rebindable
  , Just expr <- shortCutLit val ty = dsExpr expr	-- Note [Literal short cut]
  | otherwise			    = dsExpr witness
96 97
\end{code}

98 99 100 101 102 103 104 105
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
The type checker tries to do this short-cutting as early as possible, but 
becuase of unification etc, more information is available to the desugarer.
And where it's possible to generate the correct literal right away, it's
much better do do so.


106 107 108 109 110 111 112 113
\begin{code}
hsLitKey :: HsLit -> Literal
-- Get a Core literal to use (only) a grouping key
-- Hence its type doesn't need to match the type of the original literal
--	(and doesn't for strings)
-- It only works for primitive types and strings; 
-- others have been removed by tidy
hsLitKey (HsIntPrim     i) = mkMachInt  i
Ian Lynagh's avatar
Ian Lynagh committed
114
hsLitKey (HsWordPrim    w) = mkMachWord w
115 116 117 118 119
hsLitKey (HsCharPrim    c) = MachChar   c
hsLitKey (HsStringPrim  s) = MachStr    s
hsLitKey (HsFloatPrim   f) = MachFloat  f
hsLitKey (HsDoublePrim  d) = MachDouble d
hsLitKey (HsString s)	   = MachStr    s
Ian Lynagh's avatar
Ian Lynagh committed
120
hsLitKey l                 = pprPanic "hsLitKey" (ppr l)
121

Ian Lynagh's avatar
Ian Lynagh committed
122
hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
123
-- Ditto for HsOverLit; the boolean indicates to negate
124 125 126 127 128 129 130 131
hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg

litValKey :: OverLitVal -> Bool -> Literal
litValKey (HsIntegral i)   False = MachInt i
litValKey (HsIntegral i)   True  = MachInt (-i)
litValKey (HsFractional r) False = MachFloat r
litValKey (HsFractional r) True  = MachFloat (-r)
litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
132 133
\end{code}

134 135
%************************************************************************
%*									*
136
	Tidying lit pats
137 138 139
%*									*
%************************************************************************

140
\begin{code}
141
tidyLitPat :: HsLit -> Pat Id
142
-- Result has only the following HsLits:
Ian Lynagh's avatar
Ian Lynagh committed
143
--	HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
144 145 146
--	HsDoublePrim, HsStringPrim, HsString
--  * HsInteger, HsRat, HsInt can't show up in LitPats
--  * We get rid of HsChar right here
147 148
tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
tidyLitPat (HsString s)
149
  | lengthFS s <= 1	-- Short string literals only
150 151
  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
	          (mkNilPat stringTy) (unpackFS s)
152 153
	-- The stringTy is the type of the whole pattern, not 
	-- the type to instantiate (:) or [] with!
154
tidyLitPat lit = LitPat lit
155

156
----------------
157
tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
158
tidyNPat (OverLit val False _ ty) mb_neg _
159 160 161 162 163
	-- Take short cuts only if the literal is not using rebindable syntax
  | isIntTy    ty = mk_con_pat intDataCon    (HsIntPrim int_val)
  | isWordTy   ty = mk_con_pat wordDataCon   (HsWordPrim int_val)
  | isFloatTy  ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
  | isDoubleTy ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
164
--  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
165
  where
166
    mk_con_pat :: DataCon -> HsLit -> Pat Id
167
    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
168

169 170 171 172 173
    neg_val = case (mb_neg, val) of
		(Nothing, 	       _) -> val
		(Just _,  HsIntegral   i) -> HsIntegral   (-i)
		(Just _,  HsFractional f) -> HsFractional (-f)
		(Just _,  HsIsString _)	  -> panic "tidyNPat"
174 175
			     
    int_val :: Integer
176 177 178
    int_val = case neg_val of
		HsIntegral i -> i
		_ -> panic "tidyNPat"
179 180
	
    rat_val :: Rational
181 182 183 184
    rat_val = case neg_val of
		HsIntegral   i -> fromInteger i
		HsFractional f -> f
		_ -> panic "tidyNPat"
185
	
Ian Lynagh's avatar
Ian Lynagh committed
186
{-
187
    str_val :: FastString
188 189 190
    str_val = case val of
		HsIsString s -> s
		_ -> panic "tidyNPat"
Ian Lynagh's avatar
Ian Lynagh committed
191
-}
192 193 194

tidyNPat over_lit mb_neg eq 
  = NPat over_lit mb_neg eq
195 196
\end{code}

197 198 199 200 201 202

%************************************************************************
%*									*
		Pattern matching on LitPat
%*									*
%************************************************************************
203 204

\begin{code}
205
matchLiterals :: [Id]
206 207
	      -> Type			-- Type of the whole case expression
	      -> [[EquationInfo]]	-- All PgLits
208
	      -> DsM MatchResult
209

210
matchLiterals (var:vars) ty sub_groups
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
211 212
  = ASSERT( all notNull sub_groups )
    do	{	-- Deal with each group
213
	; alts <- mapM match_group sub_groups
214

215 216 217 218
	 	-- Combine results.  For everything except String
		-- we can use a case expression; for String we need
		-- a chain of if-then-else
	; if isStringTy (idType var) then
219 220
	    do	{ eq_str <- dsLookupGlobalId eqStringName
		; mrs <- mapM (wrap_str_guard eq_str) alts
221 222 223 224
		; return (foldr1 combineMatchResults mrs) }
	  else 
	    return (mkCoPrimCaseMatchResult var ty alts)
	}
225
  where
226 227 228
    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
    match_group eqns
	= do { let LitPat hs_lit = firstPat (head eqns)
229
	     ; match_result <- match vars ty (shiftEqns eqns)
230
	     ; return (hsLitKey hs_lit, match_result) }
231

232
    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
233
	-- Equality check for string literals
234 235
    wrap_str_guard eq_str (MachStr s, mr)
	= do { lit    <- mkStringExprFS s
236 237
	     ; let pred = mkApps (Var eq_str) [Var var, lit]
	     ; return (mkGuardedMatchResult pred mr) }
Ian Lynagh's avatar
Ian Lynagh committed
238 239 240
    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)

matchLiterals [] _ _ = panic "matchLiterals []"
241 242
\end{code}

243

244 245 246 247 248 249
%************************************************************************
%*									*
		Pattern matching on NPat
%*									*
%************************************************************************

250
\begin{code}
251 252 253 254 255 256
matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
	-- All NPats, but perhaps for different literals
matchNPats vars ty groups
  = do {  match_results <- mapM (matchOneNPat vars ty) groups
	; return (foldr1 combineMatchResults match_results) }

Ian Lynagh's avatar
Ian Lynagh committed
257
matchOneNPat :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
258
matchOneNPat (var:vars) ty (eqn1:eqns)	-- All for the same literal
259
  = do	{ let NPat lit mb_neg eq_chk = firstPat eqn1
260 261
	; lit_expr <- dsOverLit lit
	; neg_lit <- case mb_neg of
262 263 264
			    Nothing -> return lit_expr
			    Just neg -> do { neg_expr <- dsExpr neg
					   ; return (App neg_expr lit_expr) }
265 266 267 268
	; eq_expr <- dsExpr eq_chk
	; let pred_expr = mkApps eq_expr [Var var, neg_lit]
	; match_result <- match vars ty (shiftEqns (eqn1:eqns))
	; return (mkGuardedMatchResult pred_expr match_result) }
Ian Lynagh's avatar
Ian Lynagh committed
269
matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
270 271
\end{code}

272 273 274 275 276 277 278

%************************************************************************
%*									*
		Pattern matching on n+k patterns
%*									*
%************************************************************************

279 280 281 282 283 284 285 286 287 288
For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
    if ge var lit then
	let n = sub var lit
	in  <expr-for-a-successful-match>
    else
	<try-next-pattern-or-whatever>
\end{verbatim}

289 290

\begin{code}
291
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
Ian Lynagh's avatar
Ian Lynagh committed
292 293
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
294 295 296 297 298 299
  = do	{ let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
	; ge_expr     <- dsExpr ge
	; minus_expr  <- dsExpr minus
	; lit_expr    <- dsOverLit lit
	; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
	      minusk_expr = mkApps minus_expr [Var var, lit_expr]
300
	      (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
301 302 303 304 305
	; match_result <- match vars ty eqns'
	; return  (mkGuardedMatchResult pred_expr 		$
		   mkCoLetMatchResult (NonRec n1 minusk_expr)	$
		   adjustMatchResult (foldr1 (.) wraps)		$
		   match_result) }
306
  where
307 308 309
    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
	= (wrapBind n n1, eqn { eqn_pats = pats })
	-- The wrapBind is a no-op for the first equation
Ian Lynagh's avatar
Ian Lynagh committed
310 311 312
    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)

matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
313
\end{code}