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 )
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 (HsStringPrim s) = return (mkLit (MachStr s))
63 dsLit (HsCharPrim c) = return (mkLit (MachChar c))
64 dsLit (HsIntPrim i) = return (mkLit (MachInt i))
65 dsLit (HsWordPrim w) = return (mkLit (MachWord w))
66 dsLit (HsFloatPrim f) = return (mkLit (MachFloat f))
67 dsLit (HsDoublePrim d) = return (mkLit (MachDouble d))
69 dsLit (HsChar c) = return (mkCharExpr c)
70 dsLit (HsString str) = mkStringExprFS str
71 dsLit (HsInteger i _) = mkIntegerExpr i
72 dsLit (HsInt i) = return (mkIntExpr i)
74 dsLit (HsRat r ty) = do
75 num <- mkIntegerExpr (numerator r)
76 denom <- mkIntegerExpr (denominator r)
77 return (mkConApp ratio_data_con [Type integer_ty, num, denom])
79 (ratio_data_con, integer_ty)
80 = case tcSplitTyConApp ty of
81 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
82 (head (tyConDataCons tycon), i_ty)
83 x -> pprPanic "dsLit" (ppr x)
85 dsOverLit :: HsOverLit Id -> DsM CoreExpr
86 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
87 -- (an expression for) the literal value itself
88 dsOverLit (HsIntegral _ lit _) = dsExpr lit
89 dsOverLit (HsFractional _ lit _) = dsExpr lit
90 dsOverLit (HsIsString _ lit _) = dsExpr lit
94 hsLitKey :: HsLit -> Literal
95 -- Get a Core literal to use (only) a grouping key
96 -- Hence its type doesn't need to match the type of the original literal
97 -- (and doesn't for strings)
98 -- It only works for primitive types and strings;
99 -- others have been removed by tidy
100 hsLitKey (HsIntPrim i) = mkMachInt i
101 hsLitKey (HsWordPrim w) = mkMachWord w
102 hsLitKey (HsCharPrim c) = MachChar c
103 hsLitKey (HsStringPrim s) = MachStr s
104 hsLitKey (HsFloatPrim f) = MachFloat f
105 hsLitKey (HsDoublePrim d) = MachDouble d
106 hsLitKey (HsString s) = MachStr s
107 hsLitKey l = pprPanic "hsLitKey" (ppr l)
109 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
110 -- Ditto for HsOverLit; the boolean indicates to negate
111 hsOverLitKey (HsIntegral i _ _) False = MachInt i
112 hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
113 hsOverLitKey (HsFractional r _ _) False = MachFloat r
114 hsOverLitKey (HsFractional r _ _) True = MachFloat (-r)
115 hsOverLitKey (HsIsString s _ _) False = MachStr s
116 hsOverLitKey l _ = pprPanic "hsOverLitKey" (ppr l)
117 -- negated string should never happen
120 %************************************************************************
124 %************************************************************************
127 tidyLitPat :: HsLit -> Pat Id
128 -- Result has only the following HsLits:
129 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
130 -- HsDoublePrim, HsStringPrim, HsString
131 -- * HsInteger, HsRat, HsInt can't show up in LitPats
132 -- * We get rid of HsChar right here
133 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
134 tidyLitPat (HsString s)
135 | lengthFS s <= 1 -- Short string literals only
136 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
137 (mkNilPat stringTy) (unpackFS s)
138 -- The stringTy is the type of the whole pattern, not
139 -- the type to instantiate (:) or [] with!
140 tidyLitPat lit = LitPat lit
143 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
144 tidyNPat over_lit mb_neg eq
145 | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val)
146 | isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val)
147 | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val)
148 | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
149 -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
150 | otherwise = NPat over_lit mb_neg eq
152 mk_con_pat :: DataCon -> HsLit -> Pat Id
153 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
155 neg_lit = case (mb_neg, over_lit) of
156 (Nothing, _) -> over_lit
157 (Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty
158 (Just _, HsFractional f s ty) -> HsFractional (-f) s ty
159 (Just _, HsIsString {}) -> panic "tidyNPat/neg_lit HsIsString"
162 int_val = case neg_lit of
163 HsIntegral i _ _ -> i
164 HsFractional {} -> panic "tidyNPat/int_val HsFractional"
165 HsIsString {} -> panic "tidyNPat/int_val HsIsString"
168 rat_val = case neg_lit of
169 HsIntegral i _ _ -> fromInteger i
170 HsFractional f _ _ -> f
171 HsIsString {} -> panic "tidyNPat/rat_val HsIsString"
174 str_val :: FastString
175 str_val = case neg_lit of
176 HsIsString s _ _ -> s
177 _ -> error "tidyNPat"
182 %************************************************************************
184 Pattern matching on LitPat
186 %************************************************************************
189 matchLiterals :: [Id]
190 -> Type -- Type of the whole case expression
191 -> [[EquationInfo]] -- All PgLits
194 matchLiterals (var:vars) ty sub_groups
195 = ASSERT( all notNull sub_groups )
196 do { -- Deal with each group
197 ; alts <- mapM match_group sub_groups
199 -- Combine results. For everything except String
200 -- we can use a case expression; for String we need
201 -- a chain of if-then-else
202 ; if isStringTy (idType var) then
203 do { eq_str <- dsLookupGlobalId eqStringName
204 ; mrs <- mapM (wrap_str_guard eq_str) alts
205 ; return (foldr1 combineMatchResults mrs) }
207 return (mkCoPrimCaseMatchResult var ty alts)
210 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
212 = do { let LitPat hs_lit = firstPat (head eqns)
213 ; match_result <- match vars ty (shiftEqns eqns)
214 ; return (hsLitKey hs_lit, match_result) }
216 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
217 -- Equality check for string literals
218 wrap_str_guard eq_str (MachStr s, mr)
219 = do { lit <- mkStringExprFS s
220 ; let pred = mkApps (Var eq_str) [Var var, lit]
221 ; return (mkGuardedMatchResult pred mr) }
222 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
224 matchLiterals [] _ _ = panic "matchLiterals []"
228 %************************************************************************
230 Pattern matching on NPat
232 %************************************************************************
235 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
236 -- All NPats, but perhaps for different literals
237 matchNPats vars ty groups
238 = do { match_results <- mapM (matchOneNPat vars ty) groups
239 ; return (foldr1 combineMatchResults match_results) }
241 matchOneNPat :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
242 matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
243 = do { let NPat lit mb_neg eq_chk = firstPat eqn1
244 ; lit_expr <- dsOverLit lit
245 ; neg_lit <- case mb_neg of
246 Nothing -> return lit_expr
247 Just neg -> do { neg_expr <- dsExpr neg
248 ; return (App neg_expr lit_expr) }
249 ; eq_expr <- dsExpr eq_chk
250 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
251 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
252 ; return (mkGuardedMatchResult pred_expr match_result) }
253 matchOneNPat vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
257 %************************************************************************
259 Pattern matching on n+k patterns
261 %************************************************************************
263 For an n+k pattern, we use the various magic expressions we've been given.
268 in <expr-for-a-successful-match>
270 <try-next-pattern-or-whatever>
275 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
276 -- All NPlusKPats, for the *same* literal k
277 matchNPlusKPats (var:vars) ty (eqn1:eqns)
278 = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
279 ; ge_expr <- dsExpr ge
280 ; minus_expr <- dsExpr minus
281 ; lit_expr <- dsOverLit lit
282 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
283 minusk_expr = mkApps minus_expr [Var var, lit_expr]
284 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
285 ; match_result <- match vars ty eqns'
286 ; return (mkGuardedMatchResult pred_expr $
287 mkCoLetMatchResult (NonRec n1 minusk_expr) $
288 adjustMatchResult (foldr1 (.) wraps) $
291 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
292 = (wrapBind n n1, eqn { eqn_pats = pats })
293 -- The wrapBind is a no-op for the first equation
294 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
296 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))