2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Pattern-matching literal patterns
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
18 matchLiterals, matchNPlusKPats, matchNPats ) where
20 #include "HsVersions.h"
22 import {-# SOURCE #-} Match ( match )
23 import {-# SOURCE #-} DsExpr ( dsExpr )
46 %************************************************************************
49 [used to be in DsExpr, but DsMeta needs it,
50 and it's nice to avoid a loop]
52 %************************************************************************
54 We give int/float literals type @Integer@ and @Rational@, respectively.
55 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
58 ToDo: put in range checks for when converting ``@i@''
59 (or should that be in the typechecker?)
61 For numeric literals, we try to detect there use at a standard type
62 (@Int@, @Float@, etc.) are directly put in the right constructor.
63 [NB: down with the @App@ conversion.]
65 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
68 dsLit :: HsLit -> DsM CoreExpr
69 dsLit (HsStringPrim s) = return (mkLit (MachStr s))
70 dsLit (HsCharPrim c) = return (mkLit (MachChar c))
71 dsLit (HsIntPrim i) = return (mkLit (MachInt i))
72 dsLit (HsWordPrim w) = return (mkLit (MachWord w))
73 dsLit (HsFloatPrim f) = return (mkLit (MachFloat f))
74 dsLit (HsDoublePrim d) = return (mkLit (MachDouble d))
76 dsLit (HsChar c) = return (mkCharExpr c)
77 dsLit (HsString str) = mkStringExprFS str
78 dsLit (HsInteger i _) = mkIntegerExpr i
79 dsLit (HsInt i) = return (mkIntExpr i)
81 dsLit (HsRat r ty) = do
82 num <- mkIntegerExpr (numerator r)
83 denom <- mkIntegerExpr (denominator r)
84 return (mkConApp ratio_data_con [Type integer_ty, num, denom])
86 (ratio_data_con, integer_ty)
87 = case tcSplitTyConApp ty of
88 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
89 (head (tyConDataCons tycon), i_ty)
91 dsOverLit :: HsOverLit Id -> DsM CoreExpr
92 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
93 -- (an expression for) the literal value itself
94 dsOverLit (HsIntegral _ lit _) = dsExpr lit
95 dsOverLit (HsFractional _ lit _) = dsExpr lit
96 dsOverLit (HsIsString _ lit _) = dsExpr lit
100 hsLitKey :: HsLit -> Literal
101 -- Get a Core literal to use (only) a grouping key
102 -- Hence its type doesn't need to match the type of the original literal
103 -- (and doesn't for strings)
104 -- It only works for primitive types and strings;
105 -- others have been removed by tidy
106 hsLitKey (HsIntPrim i) = mkMachInt i
107 hsLitKey (HsWordPrim w) = mkMachWord w
108 hsLitKey (HsCharPrim c) = MachChar c
109 hsLitKey (HsStringPrim s) = MachStr s
110 hsLitKey (HsFloatPrim f) = MachFloat f
111 hsLitKey (HsDoublePrim d) = MachDouble d
112 hsLitKey (HsString s) = MachStr s
114 hsOverLitKey :: HsOverLit a -> Bool -> Literal
115 -- Ditto for HsOverLit; the boolean indicates to negate
116 hsOverLitKey (HsIntegral i _ _) False = MachInt i
117 hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
118 hsOverLitKey (HsFractional r _ _) False = MachFloat r
119 hsOverLitKey (HsFractional r _ _) True = MachFloat (-r)
120 hsOverLitKey (HsIsString s _ _) False = MachStr s
121 -- negated string should never happen
124 %************************************************************************
128 %************************************************************************
131 tidyLitPat :: HsLit -> Pat Id
132 -- Result has only the following HsLits:
133 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
134 -- HsDoublePrim, HsStringPrim, HsString
135 -- * HsInteger, HsRat, HsInt can't show up in LitPats
136 -- * We get rid of HsChar right here
137 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
138 tidyLitPat (HsString s)
139 | lengthFS s <= 1 -- Short string literals only
140 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
141 (mkNilPat stringTy) (unpackFS s)
142 -- The stringTy is the type of the whole pattern, not
143 -- the type to instantiate (:) or [] with!
144 tidyLitPat lit = LitPat lit
147 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
148 tidyNPat over_lit mb_neg eq
149 | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val)
150 | isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val)
151 | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val)
152 | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
153 -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
154 | otherwise = NPat over_lit mb_neg eq
156 mk_con_pat :: DataCon -> HsLit -> Pat Id
157 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
159 neg_lit = case (mb_neg, over_lit) of
160 (Nothing, _) -> over_lit
161 (Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty
162 (Just _, HsFractional f s ty) -> HsFractional (-f) s ty
165 int_val = case neg_lit of
166 HsIntegral i _ _ -> i
167 HsFractional f _ _ -> panic "tidyNPat"
170 rat_val = case neg_lit of
171 HsIntegral i _ _ -> fromInteger i
172 HsFractional f _ _ -> f
174 str_val :: FastString
175 str_val = case neg_lit of
176 HsIsString s _ _ -> s
177 _ -> error "tidyNPat"
181 %************************************************************************
183 Pattern matching on LitPat
185 %************************************************************************
188 matchLiterals :: [Id]
189 -> Type -- Type of the whole case expression
190 -> [[EquationInfo]] -- All PgLits
193 matchLiterals (var:vars) ty sub_groups
194 = ASSERT( all notNull sub_groups )
195 do { -- Deal with each group
196 ; alts <- mapM match_group sub_groups
198 -- Combine results. For everything except String
199 -- we can use a case expression; for String we need
200 -- a chain of if-then-else
201 ; if isStringTy (idType var) then
202 do { eq_str <- dsLookupGlobalId eqStringName
203 ; mrs <- mapM (wrap_str_guard eq_str) alts
204 ; return (foldr1 combineMatchResults mrs) }
206 return (mkCoPrimCaseMatchResult var ty alts)
209 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
211 = do { let LitPat hs_lit = firstPat (head eqns)
212 ; match_result <- match vars ty (shiftEqns eqns)
213 ; return (hsLitKey hs_lit, match_result) }
215 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
216 -- Equality check for string literals
217 wrap_str_guard eq_str (MachStr s, mr)
218 = do { lit <- mkStringExprFS s
219 ; let pred = mkApps (Var eq_str) [Var var, lit]
220 ; return (mkGuardedMatchResult pred mr) }
224 %************************************************************************
226 Pattern matching on NPat
228 %************************************************************************
231 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
232 -- All NPats, but perhaps for different literals
233 matchNPats vars ty groups
234 = do { match_results <- mapM (matchOneNPat vars ty) groups
235 ; return (foldr1 combineMatchResults match_results) }
237 matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
238 = do { let NPat lit mb_neg eq_chk = firstPat eqn1
239 ; lit_expr <- dsOverLit lit
240 ; neg_lit <- case mb_neg of
241 Nothing -> return lit_expr
242 Just neg -> do { neg_expr <- dsExpr neg
243 ; return (App neg_expr lit_expr) }
244 ; eq_expr <- dsExpr eq_chk
245 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
246 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
247 ; return (mkGuardedMatchResult pred_expr match_result) }
251 %************************************************************************
253 Pattern matching on n+k patterns
255 %************************************************************************
257 For an n+k pattern, we use the various magic expressions we've been given.
262 in <expr-for-a-successful-match>
264 <try-next-pattern-or-whatever>
269 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
270 -- All NPlusKPats, for the *same* literal k
271 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
272 = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
273 ; ge_expr <- dsExpr ge
274 ; minus_expr <- dsExpr minus
275 ; lit_expr <- dsOverLit lit
276 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
277 minusk_expr = mkApps minus_expr [Var var, lit_expr]
278 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
279 ; match_result <- match vars ty eqns'
280 ; return (mkGuardedMatchResult pred_expr $
281 mkCoLetMatchResult (NonRec n1 minusk_expr) $
282 adjustMatchResult (foldr1 (.) wraps) $
285 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
286 = (wrapBind n n1, eqn { eqn_pats = pats })
287 -- The wrapBind is a no-op for the first equation