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 )
27 import TcHsSyn ( shortCutLit )
41 %************************************************************************
44 [used to be in DsExpr, but DsMeta needs it,
45 and it's nice to avoid a loop]
47 %************************************************************************
49 We give int/float literals type @Integer@ and @Rational@, respectively.
50 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
53 ToDo: put in range checks for when converting ``@i@''
54 (or should that be in the typechecker?)
56 For numeric literals, we try to detect there use at a standard type
57 (@Int@, @Float@, etc.) are directly put in the right constructor.
58 [NB: down with the @App@ conversion.]
60 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
63 dsLit :: HsLit -> DsM CoreExpr
64 dsLit (HsStringPrim s) = return (mkLit (MachStr s))
65 dsLit (HsCharPrim c) = return (mkLit (MachChar c))
66 dsLit (HsIntPrim i) = return (mkLit (MachInt i))
67 dsLit (HsWordPrim w) = return (mkLit (MachWord w))
68 dsLit (HsFloatPrim f) = return (mkLit (MachFloat f))
69 dsLit (HsDoublePrim d) = return (mkLit (MachDouble d))
71 dsLit (HsChar c) = return (mkCharExpr c)
72 dsLit (HsString str) = mkStringExprFS str
73 dsLit (HsInteger i _) = mkIntegerExpr i
74 dsLit (HsInt i) = return (mkIntExpr i)
76 dsLit (HsRat r ty) = do
77 num <- mkIntegerExpr (numerator r)
78 denom <- mkIntegerExpr (denominator r)
79 return (mkConApp ratio_data_con [Type integer_ty, num, denom])
81 (ratio_data_con, integer_ty)
82 = case tcSplitTyConApp ty of
83 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
84 (head (tyConDataCons tycon), i_ty)
85 x -> pprPanic "dsLit" (ppr x)
87 dsOverLit :: HsOverLit Id -> DsM CoreExpr
88 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
89 -- (an expression for) the literal value itself
90 dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
91 , ol_witness = witness, ol_type = ty })
93 , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut]
94 | otherwise = dsExpr witness
97 Note [Literal short cut]
98 ~~~~~~~~~~~~~~~~~~~~~~~~
99 The type checker tries to do this short-cutting as early as possible, but
100 becuase of unification etc, more information is available to the desugarer.
101 And where it's possible to generate the correct literal right away, it's
102 much better do do so.
106 hsLitKey :: HsLit -> Literal
107 -- Get a Core literal to use (only) a grouping key
108 -- Hence its type doesn't need to match the type of the original literal
109 -- (and doesn't for strings)
110 -- It only works for primitive types and strings;
111 -- others have been removed by tidy
112 hsLitKey (HsIntPrim i) = mkMachInt i
113 hsLitKey (HsWordPrim w) = mkMachWord w
114 hsLitKey (HsCharPrim c) = MachChar c
115 hsLitKey (HsStringPrim s) = MachStr s
116 hsLitKey (HsFloatPrim f) = MachFloat f
117 hsLitKey (HsDoublePrim d) = MachDouble d
118 hsLitKey (HsString s) = MachStr s
119 hsLitKey l = pprPanic "hsLitKey" (ppr l)
121 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
122 -- Ditto for HsOverLit; the boolean indicates to negate
123 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
125 litValKey :: OverLitVal -> Bool -> Literal
126 litValKey (HsIntegral i) False = MachInt i
127 litValKey (HsIntegral i) True = MachInt (-i)
128 litValKey (HsFractional r) False = MachFloat r
129 litValKey (HsFractional r) True = MachFloat (-r)
130 litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
133 %************************************************************************
137 %************************************************************************
140 tidyLitPat :: HsLit -> Pat Id
141 -- Result has only the following HsLits:
142 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
143 -- HsDoublePrim, HsStringPrim, HsString
144 -- * HsInteger, HsRat, HsInt can't show up in LitPats
145 -- * We get rid of HsChar right here
146 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
147 tidyLitPat (HsString s)
148 | lengthFS s <= 1 -- Short string literals only
149 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
150 (mkNilPat stringTy) (unpackFS s)
151 -- The stringTy is the type of the whole pattern, not
152 -- the type to instantiate (:) or [] with!
153 tidyLitPat lit = LitPat lit
156 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
157 tidyNPat (OverLit val False _ ty) mb_neg _
158 -- Take short cuts only if the literal is not using rebindable syntax
159 | isIntTy ty = mk_con_pat intDataCon (HsIntPrim int_val)
160 | isWordTy ty = mk_con_pat wordDataCon (HsWordPrim int_val)
161 | isFloatTy ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
162 | isDoubleTy ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
163 -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
165 mk_con_pat :: DataCon -> HsLit -> Pat Id
166 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
168 neg_val = case (mb_neg, val) of
170 (Just _, HsIntegral i) -> HsIntegral (-i)
171 (Just _, HsFractional f) -> HsFractional (-f)
172 (Just _, HsIsString _) -> panic "tidyNPat"
175 int_val = case neg_val of
177 _ -> panic "tidyNPat"
180 rat_val = case neg_val of
181 HsIntegral i -> fromInteger i
183 _ -> panic "tidyNPat"
186 str_val :: FastString
187 str_val = case val of
189 _ -> panic "tidyNPat"
192 tidyNPat over_lit mb_neg eq
193 = NPat over_lit mb_neg eq
197 %************************************************************************
199 Pattern matching on LitPat
201 %************************************************************************
204 matchLiterals :: [Id]
205 -> Type -- Type of the whole case expression
206 -> [[EquationInfo]] -- All PgLits
209 matchLiterals (var:vars) ty sub_groups
210 = ASSERT( all notNull sub_groups )
211 do { -- Deal with each group
212 ; alts <- mapM match_group sub_groups
214 -- Combine results. For everything except String
215 -- we can use a case expression; for String we need
216 -- a chain of if-then-else
217 ; if isStringTy (idType var) then
218 do { eq_str <- dsLookupGlobalId eqStringName
219 ; mrs <- mapM (wrap_str_guard eq_str) alts
220 ; return (foldr1 combineMatchResults mrs) }
222 return (mkCoPrimCaseMatchResult var ty alts)
225 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
227 = do { let LitPat hs_lit = firstPat (head eqns)
228 ; match_result <- match vars ty (shiftEqns eqns)
229 ; return (hsLitKey hs_lit, match_result) }
231 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
232 -- Equality check for string literals
233 wrap_str_guard eq_str (MachStr s, mr)
234 = do { lit <- mkStringExprFS s
235 ; let pred = mkApps (Var eq_str) [Var var, lit]
236 ; return (mkGuardedMatchResult pred mr) }
237 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
239 matchLiterals [] _ _ = panic "matchLiterals []"
243 %************************************************************************
245 Pattern matching on NPat
247 %************************************************************************
250 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
251 -- All NPats, but perhaps for different literals
252 matchNPats vars ty groups
253 = do { match_results <- mapM (matchOneNPat vars ty) groups
254 ; return (foldr1 combineMatchResults match_results) }
256 matchOneNPat :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
257 matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
258 = do { let NPat lit mb_neg eq_chk = firstPat eqn1
259 ; lit_expr <- dsOverLit lit
260 ; neg_lit <- case mb_neg of
261 Nothing -> return lit_expr
262 Just neg -> do { neg_expr <- dsExpr neg
263 ; return (App neg_expr lit_expr) }
264 ; eq_expr <- dsExpr eq_chk
265 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
266 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
267 ; return (mkGuardedMatchResult pred_expr match_result) }
268 matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
272 %************************************************************************
274 Pattern matching on n+k patterns
276 %************************************************************************
278 For an n+k pattern, we use the various magic expressions we've been given.
283 in <expr-for-a-successful-match>
285 <try-next-pattern-or-whatever>
290 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
291 -- All NPlusKPats, for the *same* literal k
292 matchNPlusKPats (var:vars) ty (eqn1:eqns)
293 = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
294 ; ge_expr <- dsExpr ge
295 ; minus_expr <- dsExpr minus
296 ; lit_expr <- dsOverLit lit
297 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
298 minusk_expr = mkApps minus_expr [Var var, lit_expr]
299 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
300 ; match_result <- match vars ty eqns'
301 ; return (mkGuardedMatchResult pred_expr $
302 mkCoLetMatchResult (NonRec n1 minusk_expr) $
303 adjustMatchResult (foldr1 (.) wraps) $
306 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
307 = (wrapBind n n1, eqn { eqn_pats = pats })
308 -- The wrapBind is a no-op for the first equation
309 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
311 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))