2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[MatchLit]{Pattern-matching literal patterns}
7 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
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 DataCon ( DataCon )
24 import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy,
25 isFloatTy, isDoubleTy, isStringTy )
27 import PrelNames ( ratioTyConKey )
28 import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
29 import PrelNames ( eqStringName )
30 import Unique ( hasKey )
31 import Literal ( mkMachInt, Literal(..) )
32 import SrcLoc ( noLoc )
33 import Ratio ( numerator, denominator )
34 import SrcLoc ( Located(..), unLoc )
36 import Util ( mapAndUnzip )
37 import FastString ( lengthFS, unpackFS )
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) = returnDs (mkLit (MachStr s))
64 dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
65 dsLit (HsIntPrim i) = returnDs (mkLit (MachInt i))
66 dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
67 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
69 dsLit (HsChar c) = returnDs (mkCharExpr c)
70 dsLit (HsString str) = mkStringExprFS str
71 dsLit (HsInteger i _) = mkIntegerExpr i
72 dsLit (HsInt i) = returnDs (mkIntExpr i)
75 = mkIntegerExpr (numerator r) `thenDs` \ num ->
76 mkIntegerExpr (denominator r) `thenDs` \ denom ->
77 returnDs (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)
84 dsOverLit :: HsOverLit Id -> DsM CoreExpr
85 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
86 -- (an expression for) the literal value itself
87 dsOverLit (HsIntegral _ lit) = dsExpr lit
88 dsOverLit (HsFractional _ lit) = dsExpr lit
92 hsLitKey :: HsLit -> Literal
93 -- Get a Core literal to use (only) a grouping key
94 -- Hence its type doesn't need to match the type of the original literal
95 -- (and doesn't for strings)
96 -- It only works for primitive types and strings;
97 -- others have been removed by tidy
98 hsLitKey (HsIntPrim i) = mkMachInt i
99 hsLitKey (HsCharPrim c) = MachChar c
100 hsLitKey (HsStringPrim s) = MachStr s
101 hsLitKey (HsFloatPrim f) = MachFloat f
102 hsLitKey (HsDoublePrim d) = MachDouble d
103 hsLitKey (HsString s) = MachStr s
105 hsOverLitKey :: HsOverLit a -> Bool -> Literal
106 -- Ditto for HsOverLit; the boolean indicates to negate
107 hsOverLitKey (HsIntegral i _) False = MachInt i
108 hsOverLitKey (HsIntegral i _) True = MachInt (-i)
109 hsOverLitKey (HsFractional r _) False = MachFloat r
110 hsOverLitKey (HsFractional r _) True = MachFloat (-r)
113 %************************************************************************
117 %************************************************************************
120 tidyLitPat :: HsLit -> Pat Id
121 -- Result has only the following HsLits:
122 -- HsIntPrim, HsCharPrim, HsFloatPrim
123 -- HsDoublePrim, HsStringPrim, HsString
124 -- * HsInteger, HsRat, HsInt can't show up in LitPats
125 -- * We get rid of HsChar right here
126 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
127 tidyLitPat (HsString s)
128 | lengthFS s <= 1 -- Short string literals only
129 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
130 (mkNilPat stringTy) (unpackFS s)
131 -- The stringTy is the type of the whole pattern, not
132 -- the type to instantiate (:) or [] with!
133 tidyLitPat lit = LitPat lit
136 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
138 tidyNPat over_lit mb_neg eq lit_ty
139 | isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
140 | isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
141 | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
142 | otherwise = NPat over_lit mb_neg eq lit_ty
144 mk_con_pat :: DataCon -> HsLit -> Pat Id
145 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
146 neg_lit = case (mb_neg, over_lit) of
147 (Nothing, _) -> over_lit
148 (Just _, HsIntegral i s) -> HsIntegral (-i) s
149 (Just _, HsFractional f s) -> HsFractional (-f) s
152 int_val = case neg_lit of
154 HsFractional f _ -> panic "tidyNPat"
157 rat_val = case neg_lit of
158 HsIntegral i _ -> fromInteger i
159 HsFractional f _ -> f
163 %************************************************************************
165 Pattern matching on LitPat
167 %************************************************************************
170 matchLiterals :: [Id]
171 -> Type -- Type of the whole case expression
172 -> [[EquationInfo]] -- All PgLits
175 matchLiterals (var:vars) ty sub_groups
176 = do { -- Deal with each group
177 ; alts <- mapM match_group sub_groups
179 -- Combine results. For everything except String
180 -- we can use a case expression; for String we need
181 -- a chain of if-then-else
182 ; if isStringTy (idType var) then
183 do { eq_str <- dsLookupGlobalId eqStringName
184 ; mrs <- mapM (wrap_str_guard eq_str) alts
185 ; return (foldr1 combineMatchResults mrs) }
187 return (mkCoPrimCaseMatchResult var ty alts)
190 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
192 = do { let LitPat hs_lit = firstPat (head eqns)
193 ; match_result <- match vars ty (shiftEqns eqns)
194 ; return (hsLitKey hs_lit, match_result) }
196 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
197 -- Equality check for string literals
198 wrap_str_guard eq_str (MachStr s, mr)
199 = do { lit <- mkStringExprFS s
200 ; let pred = mkApps (Var eq_str) [Var var, lit]
201 ; return (mkGuardedMatchResult pred mr) }
205 %************************************************************************
207 Pattern matching on NPat
209 %************************************************************************
212 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
213 -- All NPats, but perhaps for different literals
214 matchNPats vars ty groups
215 = do { match_results <- mapM (matchOneNPat vars ty) groups
216 ; return (foldr1 combineMatchResults match_results) }
218 matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
219 = do { let NPat lit mb_neg eq_chk _ = firstPat eqn1
220 ; lit_expr <- dsOverLit lit
221 ; neg_lit <- case mb_neg of
222 Nothing -> return lit_expr
223 Just neg -> do { neg_expr <- dsExpr neg
224 ; return (App neg_expr lit_expr) }
225 ; eq_expr <- dsExpr eq_chk
226 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
227 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
228 ; return (mkGuardedMatchResult pred_expr match_result) }
232 %************************************************************************
234 Pattern matching on n+k patterns
236 %************************************************************************
238 For an n+k pattern, we use the various magic expressions we've been given.
243 in <expr-for-a-successful-match>
245 <try-next-pattern-or-whatever>
250 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
251 -- All NPlusKPats, for the *same* literal k
252 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
253 = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
254 ; ge_expr <- dsExpr ge
255 ; minus_expr <- dsExpr minus
256 ; lit_expr <- dsOverLit lit
257 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
258 minusk_expr = mkApps minus_expr [Var var, lit_expr]
259 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
260 ; match_result <- match vars ty eqns'
261 ; return (mkGuardedMatchResult pred_expr $
262 mkCoLetMatchResult (NonRec n1 minusk_expr) $
263 adjustMatchResult (foldr1 (.) wraps) $
266 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
267 = (wrapBind n n1, eqn { eqn_pats = pats })
268 -- The wrapBind is a no-op for the first equation