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) = returnDs (mkLit (MachStr s))
70 dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
71 dsLit (HsIntPrim i) = returnDs (mkLit (MachInt i))
72 dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
73 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
75 dsLit (HsChar c) = returnDs (mkCharExpr c)
76 dsLit (HsString str) = mkStringExprFS str
77 dsLit (HsInteger i _) = mkIntegerExpr i
78 dsLit (HsInt i) = returnDs (mkIntExpr i)
81 = mkIntegerExpr (numerator r) `thenDs` \ num ->
82 mkIntegerExpr (denominator r) `thenDs` \ denom ->
83 returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
85 (ratio_data_con, integer_ty)
86 = case tcSplitTyConApp ty of
87 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
88 (head (tyConDataCons tycon), i_ty)
90 dsOverLit :: HsOverLit Id -> DsM CoreExpr
91 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
92 -- (an expression for) the literal value itself
93 dsOverLit (HsIntegral _ lit _) = dsExpr lit
94 dsOverLit (HsFractional _ lit _) = dsExpr lit
95 dsOverLit (HsIsString _ lit _) = dsExpr lit
99 hsLitKey :: HsLit -> Literal
100 -- Get a Core literal to use (only) a grouping key
101 -- Hence its type doesn't need to match the type of the original literal
102 -- (and doesn't for strings)
103 -- It only works for primitive types and strings;
104 -- others have been removed by tidy
105 hsLitKey (HsIntPrim i) = mkMachInt i
106 hsLitKey (HsCharPrim c) = MachChar c
107 hsLitKey (HsStringPrim s) = MachStr s
108 hsLitKey (HsFloatPrim f) = MachFloat f
109 hsLitKey (HsDoublePrim d) = MachDouble d
110 hsLitKey (HsString s) = MachStr s
112 hsOverLitKey :: HsOverLit a -> Bool -> Literal
113 -- Ditto for HsOverLit; the boolean indicates to negate
114 hsOverLitKey (HsIntegral i _ _) False = MachInt i
115 hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
116 hsOverLitKey (HsFractional r _ _) False = MachFloat r
117 hsOverLitKey (HsFractional r _ _) True = MachFloat (-r)
118 hsOverLitKey (HsIsString s _ _) False = MachStr s
119 -- negated string should never happen
122 %************************************************************************
126 %************************************************************************
129 tidyLitPat :: HsLit -> Pat Id
130 -- Result has only the following HsLits:
131 -- HsIntPrim, HsCharPrim, HsFloatPrim
132 -- HsDoublePrim, HsStringPrim, HsString
133 -- * HsInteger, HsRat, HsInt can't show up in LitPats
134 -- * We get rid of HsChar right here
135 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
136 tidyLitPat (HsString s)
137 | lengthFS s <= 1 -- Short string literals only
138 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
139 (mkNilPat stringTy) (unpackFS s)
140 -- The stringTy is the type of the whole pattern, not
141 -- the type to instantiate (:) or [] with!
142 tidyLitPat lit = LitPat lit
145 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
146 tidyNPat over_lit mb_neg eq
147 | isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val)
148 | isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val)
149 | isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
150 -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
151 | otherwise = NPat over_lit mb_neg eq
153 mk_con_pat :: DataCon -> HsLit -> Pat Id
154 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
156 neg_lit = case (mb_neg, over_lit) of
157 (Nothing, _) -> over_lit
158 (Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty
159 (Just _, HsFractional f s ty) -> HsFractional (-f) s ty
162 int_val = case neg_lit of
163 HsIntegral i _ _ -> i
164 HsFractional f _ _ -> panic "tidyNPat"
167 rat_val = case neg_lit of
168 HsIntegral i _ _ -> fromInteger i
169 HsFractional f _ _ -> f
171 str_val :: FastString
172 str_val = case neg_lit of
173 HsIsString s _ _ -> s
174 _ -> error "tidyNPat"
178 %************************************************************************
180 Pattern matching on LitPat
182 %************************************************************************
185 matchLiterals :: [Id]
186 -> Type -- Type of the whole case expression
187 -> [[EquationInfo]] -- All PgLits
190 matchLiterals (var:vars) ty sub_groups
191 = ASSERT( all notNull sub_groups )
192 do { -- Deal with each group
193 ; alts <- mapM match_group sub_groups
195 -- Combine results. For everything except String
196 -- we can use a case expression; for String we need
197 -- a chain of if-then-else
198 ; if isStringTy (idType var) then
199 do { eq_str <- dsLookupGlobalId eqStringName
200 ; mrs <- mapM (wrap_str_guard eq_str) alts
201 ; return (foldr1 combineMatchResults mrs) }
203 return (mkCoPrimCaseMatchResult var ty alts)
206 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
208 = do { let LitPat hs_lit = firstPat (head eqns)
209 ; match_result <- match vars ty (shiftEqns eqns)
210 ; return (hsLitKey hs_lit, match_result) }
212 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
213 -- Equality check for string literals
214 wrap_str_guard eq_str (MachStr s, mr)
215 = do { lit <- mkStringExprFS s
216 ; let pred = mkApps (Var eq_str) [Var var, lit]
217 ; return (mkGuardedMatchResult pred mr) }
221 %************************************************************************
223 Pattern matching on NPat
225 %************************************************************************
228 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
229 -- All NPats, but perhaps for different literals
230 matchNPats vars ty groups
231 = do { match_results <- mapM (matchOneNPat vars ty) groups
232 ; return (foldr1 combineMatchResults match_results) }
234 matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
235 = do { let NPat lit mb_neg eq_chk = firstPat eqn1
236 ; lit_expr <- dsOverLit lit
237 ; neg_lit <- case mb_neg of
238 Nothing -> return lit_expr
239 Just neg -> do { neg_expr <- dsExpr neg
240 ; return (App neg_expr lit_expr) }
241 ; eq_expr <- dsExpr eq_chk
242 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
243 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
244 ; return (mkGuardedMatchResult pred_expr match_result) }
248 %************************************************************************
250 Pattern matching on n+k patterns
252 %************************************************************************
254 For an n+k pattern, we use the various magic expressions we've been given.
259 in <expr-for-a-successful-match>
261 <try-next-pattern-or-whatever>
266 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
267 -- All NPlusKPats, for the *same* literal k
268 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
269 = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
270 ; ge_expr <- dsExpr ge
271 ; minus_expr <- dsExpr minus
272 ; lit_expr <- dsOverLit lit
273 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
274 minusk_expr = mkApps minus_expr [Var var, lit_expr]
275 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
276 ; match_result <- match vars ty eqns'
277 ; return (mkGuardedMatchResult pred_expr $
278 mkCoLetMatchResult (NonRec n1 minusk_expr) $
279 adjustMatchResult (foldr1 (.) wraps) $
282 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
283 = (wrapBind n n1, eqn { eqn_pats = pats })
284 -- The wrapBind is a no-op for the first equation