2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[MatchLit]{Pattern-matching literal patterns}
7 module MatchLit ( dsLit, dsOverLit,
9 matchLiterals, matchNPlusKPats, matchNPats ) where
11 #include "HsVersions.h"
13 import {-# SOURCE #-} Match ( match )
14 import {-# SOURCE #-} DsExpr ( dsExpr )
20 import Id ( Id, idType )
22 import TyCon ( tyConDataCons )
23 import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy,
24 isFloatTy, isDoubleTy, isStringTy )
26 import PrelNames ( ratioTyConKey )
27 import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
28 import PrelNames ( eqStringName )
29 import Unique ( hasKey )
30 import Literal ( mkMachInt, Literal(..) )
31 import SrcLoc ( noLoc )
32 import ListSetOps ( equivClasses, runs )
33 import Ratio ( numerator, denominator )
34 import SrcLoc ( Located(..) )
36 import FastString ( lengthFS, unpackFS )
39 %************************************************************************
42 [used to be in DsExpr, but DsMeta needs it,
43 and it's nice to avoid a loop]
45 %************************************************************************
47 We give int/float literals type @Integer@ and @Rational@, respectively.
48 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
51 ToDo: put in range checks for when converting ``@i@''
52 (or should that be in the typechecker?)
54 For numeric literals, we try to detect there use at a standard type
55 (@Int@, @Float@, etc.) are directly put in the right constructor.
56 [NB: down with the @App@ conversion.]
58 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
61 dsLit :: HsLit -> DsM CoreExpr
62 dsLit (HsChar c) = returnDs (mkCharExpr c)
63 dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
64 dsLit (HsString str) = mkStringExprFS str
65 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
66 dsLit (HsInteger i _) = mkIntegerExpr i
67 dsLit (HsInt i) = returnDs (mkIntExpr i)
68 dsLit (HsIntPrim i) = returnDs (mkIntLit i)
69 dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
70 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
73 = mkIntegerExpr (numerator r) `thenDs` \ num ->
74 mkIntegerExpr (denominator r) `thenDs` \ denom ->
75 returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
77 (ratio_data_con, integer_ty)
78 = case tcSplitTyConApp ty of
79 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
80 (head (tyConDataCons tycon), i_ty)
82 dsOverLit :: HsOverLit Id -> DsM CoreExpr
83 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
84 -- (an expression for) the literal value itself
85 dsOverLit (HsIntegral _ lit) = dsExpr lit
86 dsOverLit (HsFractional _ lit) = dsExpr lit
89 %************************************************************************
93 %************************************************************************
96 tidyLitPat :: HsLit -> LPat Id -> LPat Id
97 -- Result has only the following HsLits:
98 -- HsIntPrim, HsCharPrim, HsFloatPrim
99 -- HsDoublePrim, HsStringPrim, HsString
100 -- * HsInteger, HsRat, HsInt can't show up in LitPats
101 -- * We get rid of HsChar right here
102 tidyLitPat (HsChar c) pat = mkCharLitPat c
103 tidyLitPat (HsString s) pat
104 | lengthFS s <= 1 -- Short string literals only
105 = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
106 (mkNilPat stringTy) (unpackFS s)
107 -- The stringTy is the type of the whole pattern, not
108 -- the type to instantiate (:) or [] with!
109 tidyLitPat lit pat = pat
112 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> LPat Id -> LPat Id
113 tidyNPat over_lit mb_neg lit_ty default_pat
114 | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
115 | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
116 | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
117 | otherwise = default_pat
119 mk_con_pat con lit = mkPrefixConPat con [noLoc $ LitPat lit] lit_ty
120 neg_lit = case (mb_neg, over_lit) of
121 (Nothing, _) -> over_lit
122 (Just _, HsIntegral i s) -> HsIntegral (-i) s
123 (Just _, HsFractional f s) -> HsFractional (-f) s
126 int_val = case neg_lit of
128 HsFractional f _ -> panic "tidyNPat"
131 rat_val = case neg_lit of
132 HsIntegral i _ -> fromInteger i
133 HsFractional f _ -> f
137 %************************************************************************
139 Pattern matching on LitPat
141 %************************************************************************
144 matchLiterals :: [Id]
145 -> Type -- Type of the whole case expression
148 -- All the EquationInfos have LitPats at the front
150 matchLiterals (var:vars) ty eqns
151 = do { -- Group by literal
152 let groups :: [[(Literal, EquationInfo)]]
153 groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
155 -- Deal with each group
156 ; alts <- mapM match_group groups
158 -- Combine results. For everything except String
159 -- we can use a case expression; for String we need
160 -- a chain of if-then-else
161 ; if isStringTy (idType var) then
162 do { mrs <- mapM wrap_str_guard alts
163 ; return (foldr1 combineMatchResults mrs) }
165 return (mkCoPrimCaseMatchResult var ty alts)
168 match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
170 = do { let (lits, eqns) = unzip group
171 ; match_result <- match vars ty (shiftEqns eqns)
172 ; return (head lits, match_result) }
174 wrap_str_guard :: (Literal,MatchResult) -> DsM MatchResult
175 -- Equality check for string literals
176 wrap_str_guard (MachStr s, mr)
177 = do { eq_str <- dsLookupGlobalId eqStringName
178 ; lit <- mkStringExprFS s
179 ; let pred = mkApps (Var eq_str) [Var var, lit]
180 ; return (mkGuardedMatchResult pred mr) }
183 %************************************************************************
185 Pattern matching on NPat
187 %************************************************************************
190 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
191 -- All the EquationInfos have NPat at the front
193 matchNPats (var:vars) ty eqns
194 = do { let groups :: [[(Literal, EquationInfo)]]
195 groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
197 ; match_results <- mapM (match_group . map snd) groups
199 ; ASSERT( not (null match_results) )
200 return (foldr1 combineMatchResults match_results) }
202 match_group :: [EquationInfo] -> DsM MatchResult
203 match_group (eqn1:eqns)
204 = do { lit_expr <- dsOverLit lit
205 ; neg_lit <- case mb_neg of
206 Nothing -> return lit_expr
207 Just neg -> do { neg_expr <- dsExpr neg
208 ; return (App neg_expr lit_expr) }
209 ; eq_expr <- dsExpr eq_chk
210 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
211 ; match_result <- match vars ty (eqn1' : shiftEqns eqns)
212 ; return (adjustMatchResult (eqn_wrap eqn1) $
213 -- Bring the eqn1 wrapper stuff into scope because
214 -- it may be used in pred_expr
215 mkGuardedMatchResult pred_expr match_result) }
217 NPat lit mb_neg eq_chk _ : pats1 = eqn_pats eqn1
218 eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
222 %************************************************************************
224 Pattern matching on n+k patterns
226 %************************************************************************
228 For an n+k pattern, we use the various magic expressions we've been given.
233 in <expr-for-a-successful-match>
235 <try-next-pattern-or-whatever>
244 We can't group the first and third together, because the second may match
245 the same thing as the first. Contrast
249 where we can group the first and third. Hence 'runs' rather than 'equivClasses'
252 matchNPlusKPats all_vars@(var:vars) ty eqns
253 = do { let groups :: [[(Literal, EquationInfo)]]
254 groups = runs eqTaggedEqn (tagLitEqns eqns)
256 ; match_results <- mapM (match_group . map snd) groups
258 ; ASSERT( not (null match_results) )
259 return (foldr1 combineMatchResults match_results) }
261 match_group :: [EquationInfo] -> DsM MatchResult
262 match_group (eqn1:eqns)
263 = do { ge_expr <- dsExpr ge
264 ; minus_expr <- dsExpr minus
265 ; lit_expr <- dsOverLit lit
266 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
267 minusk_expr = mkApps minus_expr [Var var, lit_expr]
268 ; match_result <- match vars ty (eqn1' : map shift eqns)
269 ; return (adjustMatchResult (eqn_wrap eqn1) $
270 -- Bring the eqn1 wrapper stuff into scope because
271 -- it may be used in ge_expr, minusk_expr
272 mkGuardedMatchResult pred_expr $
273 mkCoLetMatchResult (NonRec n1 minusk_expr) $
276 NPlusKPat (L _ n1) lit ge minus : pats1 = eqn_pats eqn1
277 eqn1' = eqn1 { eqn_wrap = idWrapper, eqn_pats = pats1 }
279 shift eqn@(EqnInfo { eqn_wrap = wrap,
280 eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
281 = eqn { eqn_wrap = wrap . wrapBind n n1, eqn_pats = pats }
285 %************************************************************************
289 %************************************************************************
291 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
292 that are ``same''/different as one we are looking at. We need to know
293 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
296 -- Tag equations by the leading literal
297 -- NB: we have ordering on Core Literals, but not on HsLits
298 cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
299 cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
301 eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
302 eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
304 tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
305 tagLitEqns eqns = [(get_lit (firstPat eqn), eqn) | eqn <- eqns]
307 get_lit :: Pat Id -> Literal
308 -- Get a Core literal to use (only) a grouping key
309 -- Hence its type doesn't need to match the type of the original literal
310 get_lit (LitPat (HsIntPrim i)) = mkMachInt i
311 get_lit (LitPat (HsCharPrim c)) = MachChar c
312 get_lit (LitPat (HsStringPrim s)) = MachStr s
313 get_lit (LitPat (HsFloatPrim f)) = MachFloat f
314 get_lit (LitPat (HsDoublePrim d)) = MachDouble d
315 get_lit (LitPat (HsString s)) = MachStr s
317 get_lit (NPat (HsIntegral i _) Nothing _ _) = MachInt i
318 get_lit (NPat (HsIntegral i _) (Just _) _ _) = MachInt (-i)
319 get_lit (NPat (HsFractional r _) Nothing _ _) = MachFloat r
320 get_lit (NPat (HsFractional r _) (Just _) _ _) = MachFloat (-r)
322 get_lit (NPlusKPat _ (HsIntegral i _) _ _) = MachInt i
324 -- These ones can't happen
325 -- get_lit (LitPat (HsChar c))
326 -- get_lit (LitPat (HsInt i))
327 get_lit other = pprPanic "get_lit:bad pattern" (ppr other)