2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Pattern-matching literal patterns
9 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
11 matchLiterals, matchNPlusKPats, matchNPats ) where
13 #include "HsVersions.h"
15 import {-# SOURCE #-} Match ( match )
16 import {-# SOURCE #-} DsExpr ( dsExpr )
28 import TcHsSyn ( shortCutLit )
40 %************************************************************************
43 [used to be in DsExpr, but DsMeta needs it,
44 and it's nice to avoid a loop]
46 %************************************************************************
48 We give int/float literals type @Integer@ and @Rational@, respectively.
49 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
52 ToDo: put in range checks for when converting ``@i@''
53 (or should that be in the typechecker?)
55 For numeric literals, we try to detect there use at a standard type
56 (@Int@, @Float@, etc.) are directly put in the right constructor.
57 [NB: down with the @App@ conversion.]
59 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
62 dsLit :: HsLit -> DsM CoreExpr
63 dsLit (HsStringPrim s) = return (Lit (MachStr s))
64 dsLit (HsCharPrim c) = return (Lit (MachChar c))
65 dsLit (HsIntPrim i) = return (Lit (MachInt i))
66 dsLit (HsWordPrim w) = return (Lit (MachWord w))
67 dsLit (HsFloatPrim f) = return (Lit (MachFloat f))
68 dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
70 dsLit (HsChar c) = return (mkCharExpr c)
71 dsLit (HsString str) = mkStringExprFS str
72 dsLit (HsInteger i _) = mkIntegerExpr i
73 dsLit (HsInt i) = return (mkIntExpr i)
75 dsLit (HsRat r ty) = do
76 num <- mkIntegerExpr (numerator r)
77 denom <- mkIntegerExpr (denominator r)
78 return (mkConApp ratio_data_con [Type integer_ty, num, denom])
80 (ratio_data_con, integer_ty)
81 = case tcSplitTyConApp ty of
82 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
83 (head (tyConDataCons tycon), i_ty)
84 x -> pprPanic "dsLit" (ppr x)
86 dsOverLit :: HsOverLit Id -> DsM CoreExpr
87 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
88 -- (an expression for) the literal value itself
89 dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
90 , ol_witness = witness, ol_type = ty })
92 , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut]
93 | otherwise = dsExpr witness
96 Note [Literal short cut]
97 ~~~~~~~~~~~~~~~~~~~~~~~~
98 The type checker tries to do this short-cutting as early as possible, but
99 becuase of unification etc, more information is available to the desugarer.
100 And where it's possible to generate the correct literal right away, it's
101 much better do do so.
105 hsLitKey :: HsLit -> Literal
106 -- Get a Core literal to use (only) a grouping key
107 -- Hence its type doesn't need to match the type of the original literal
108 -- (and doesn't for strings)
109 -- It only works for primitive types and strings;
110 -- others have been removed by tidy
111 hsLitKey (HsIntPrim i) = mkMachInt i
112 hsLitKey (HsWordPrim w) = mkMachWord w
113 hsLitKey (HsCharPrim c) = MachChar c
114 hsLitKey (HsStringPrim s) = MachStr s
115 hsLitKey (HsFloatPrim f) = MachFloat f
116 hsLitKey (HsDoublePrim d) = MachDouble d
117 hsLitKey (HsString s) = MachStr s
118 hsLitKey l = pprPanic "hsLitKey" (ppr l)
120 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
121 -- Ditto for HsOverLit; the boolean indicates to negate
122 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
124 litValKey :: OverLitVal -> Bool -> Literal
125 litValKey (HsIntegral i) False = MachInt i
126 litValKey (HsIntegral i) True = MachInt (-i)
127 litValKey (HsFractional r) False = MachFloat r
128 litValKey (HsFractional r) True = MachFloat (-r)
129 litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
132 %************************************************************************
136 %************************************************************************
139 tidyLitPat :: HsLit -> Pat Id
140 -- Result has only the following HsLits:
141 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
142 -- HsDoublePrim, HsStringPrim, HsString
143 -- * HsInteger, HsRat, HsInt can't show up in LitPats
144 -- * We get rid of HsChar right here
145 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
146 tidyLitPat (HsString s)
147 | lengthFS s <= 1 -- Short string literals only
148 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
149 (mkNilPat stringTy) (unpackFS s)
150 -- The stringTy is the type of the whole pattern, not
151 -- the type to instantiate (:) or [] with!
152 tidyLitPat lit = LitPat lit
155 tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
156 -- We need this argument because tidyNPat is called
157 -- both by Match and by Check, but they tidy LitPats
158 -- slightly differently; and we must desugar
159 -- literals consistently (see Trac #5117)
160 -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
162 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
163 -- False: Take short cuts only if the literal is not using rebindable syntax
165 -- Once that is settled, look for cases where the type of the
166 -- entire overloaded literal matches the type of the underlying literal,
167 -- and in that case take the short cut
168 -- NB: Watch out for wierd cases like Trac #3382
171 -- which might be ok if we hvae 'instance IsString Int'
174 | isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit)
175 | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
176 | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
177 | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
178 | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
180 mk_con_pat :: DataCon -> HsLit -> Pat Id
181 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
183 mb_int_lit :: Maybe Integer
184 mb_int_lit = case (mb_neg, val) of
185 (Nothing, HsIntegral i) -> Just i
186 (Just _, HsIntegral i) -> Just (-i)
189 mb_rat_lit :: Maybe Rational
190 mb_rat_lit = case (mb_neg, val) of
191 (Nothing, HsIntegral i) -> Just (fromInteger i)
192 (Just _, HsIntegral i) -> Just (fromInteger (-i))
193 (Nothing, HsFractional f) -> Just f
194 (Just _, HsFractional f) -> Just (-f)
197 mb_str_lit :: Maybe FastString
198 mb_str_lit = case (mb_neg, val) of
199 (Nothing, HsIsString s) -> Just s
202 tidyNPat _ over_lit mb_neg eq
203 = NPat over_lit mb_neg eq
207 %************************************************************************
209 Pattern matching on LitPat
211 %************************************************************************
214 matchLiterals :: [Id]
215 -> Type -- Type of the whole case expression
216 -> [[EquationInfo]] -- All PgLits
219 matchLiterals (var:vars) ty sub_groups
220 = ASSERT( all notNull sub_groups )
221 do { -- Deal with each group
222 ; alts <- mapM match_group sub_groups
224 -- Combine results. For everything except String
225 -- we can use a case expression; for String we need
226 -- a chain of if-then-else
227 ; if isStringTy (idType var) then
228 do { eq_str <- dsLookupGlobalId eqStringName
229 ; mrs <- mapM (wrap_str_guard eq_str) alts
230 ; return (foldr1 combineMatchResults mrs) }
232 return (mkCoPrimCaseMatchResult var ty alts)
235 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
237 = do { let LitPat hs_lit = firstPat (head eqns)
238 ; match_result <- match vars ty (shiftEqns eqns)
239 ; return (hsLitKey hs_lit, match_result) }
241 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
242 -- Equality check for string literals
243 wrap_str_guard eq_str (MachStr s, mr)
244 = do { lit <- mkStringExprFS s
245 ; let pred = mkApps (Var eq_str) [Var var, lit]
246 ; return (mkGuardedMatchResult pred mr) }
247 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
249 matchLiterals [] _ _ = panic "matchLiterals []"
253 %************************************************************************
255 Pattern matching on NPat
257 %************************************************************************
260 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
261 matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
262 = do { let NPat lit mb_neg eq_chk = firstPat eqn1
263 ; lit_expr <- dsOverLit lit
264 ; neg_lit <- case mb_neg of
265 Nothing -> return lit_expr
266 Just neg -> do { neg_expr <- dsExpr neg
267 ; return (App neg_expr lit_expr) }
268 ; eq_expr <- dsExpr eq_chk
269 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
270 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
271 ; return (mkGuardedMatchResult pred_expr match_result) }
272 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
276 %************************************************************************
278 Pattern matching on n+k patterns
280 %************************************************************************
282 For an n+k pattern, we use the various magic expressions we've been given.
287 in <expr-for-a-successful-match>
289 <try-next-pattern-or-whatever>
294 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
295 -- All NPlusKPats, for the *same* literal k
296 matchNPlusKPats (var:vars) ty (eqn1:eqns)
297 = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
298 ; ge_expr <- dsExpr ge
299 ; minus_expr <- dsExpr minus
300 ; lit_expr <- dsOverLit lit
301 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
302 minusk_expr = mkApps minus_expr [Var var, lit_expr]
303 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
304 ; match_result <- match vars ty eqns'
305 ; return (mkGuardedMatchResult pred_expr $
306 mkCoLetMatchResult (NonRec n1 minusk_expr) $
307 adjustMatchResult (foldr1 (.) wraps) $
310 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
311 = (wrapBind n n1, eqn { eqn_pats = pats })
312 -- The wrapBind is a no-op for the first equation
313 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
315 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))