2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[MatchLit]{Pattern-matching literal patterns}
7 module MatchLit ( dsLit, tidyLitPat, tidyNPat,
8 matchLiterals, matchNPlusKPats, matchNPats ) where
10 #include "HsVersions.h"
12 import {-# SOURCE #-} Match ( match )
13 import {-# SOURCE #-} DsExpr ( dsExpr )
21 import TyCon ( tyConDataCons )
22 import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy )
24 import PrelNames ( ratioTyConKey )
25 import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon )
26 import Unique ( hasKey )
27 import Literal ( mkMachInt, Literal(..) )
28 import SrcLoc ( noLoc )
29 import ListSetOps ( equivClasses, runs )
30 import Ratio ( numerator, denominator )
31 import SrcLoc ( Located(..) )
33 import FastString ( lengthFS, unpackFS )
36 %************************************************************************
39 [used to be in DsExpr, but DsMeta needs it,
40 and it's nice to avoid a loop]
42 %************************************************************************
44 We give int/float literals type @Integer@ and @Rational@, respectively.
45 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
48 ToDo: put in range checks for when converting ``@i@''
49 (or should that be in the typechecker?)
51 For numeric literals, we try to detect there use at a standard type
52 (@Int@, @Float@, etc.) are directly put in the right constructor.
53 [NB: down with the @App@ conversion.]
55 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
58 dsLit :: HsLit -> DsM CoreExpr
59 dsLit (HsChar c) = returnDs (mkCharExpr c)
60 dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
61 dsLit (HsString str) = mkStringExprFS str
62 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
63 dsLit (HsInteger i _) = mkIntegerExpr i
64 dsLit (HsInt i) = returnDs (mkIntExpr i)
65 dsLit (HsIntPrim i) = returnDs (mkIntLit i)
66 dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
67 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
70 = mkIntegerExpr (numerator r) `thenDs` \ num ->
71 mkIntegerExpr (denominator r) `thenDs` \ denom ->
72 returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
74 (ratio_data_con, integer_ty)
75 = case tcSplitTyConApp ty of
76 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
77 (head (tyConDataCons tycon), i_ty)
80 %************************************************************************
84 %************************************************************************
87 tidyLitPat :: HsLit -> LPat Id -> LPat Id
88 -- Result has only the following HsLits:
89 -- HsIntPrim, HsCharPrim, HsFloatPrim
90 -- HsDoublePrim, HsStringPrim ?
91 -- * HsInteger, HsRat, HsInt can't show up in LitPats,
92 -- * HsString has been turned into an NPat in tcPat
93 -- and we get rid of HsChar right here
94 tidyLitPat (HsChar c) pat = mkCharLitPat c
95 tidyLitPat lit pat = pat
97 tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id
98 tidyNPat (HsString s) _ pat
99 | lengthFS s <= 1 -- Short string literals only
100 = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
101 (mkNilPat stringTy) (unpackFS s)
102 -- The stringTy is the type of the whole pattern, not
103 -- the type to instantiate (:) or [] with!
105 tidyNPat lit lit_ty default_pat
106 | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty
107 | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty
108 | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty
109 | otherwise = default_pat
112 mk_int (HsInteger i _) = HsIntPrim i
114 mk_float (HsInteger i _) = HsFloatPrim (fromInteger i)
115 mk_float (HsRat f _) = HsFloatPrim f
117 mk_double (HsInteger i _) = HsDoublePrim (fromInteger i)
118 mk_double (HsRat f _) = HsDoublePrim f
122 %************************************************************************
124 Pattern matching on LitPat
126 %************************************************************************
129 matchLiterals :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
130 -- All the EquationInfos have LitPats at the front
132 matchLiterals (var:vars) ty eqns
133 = do { -- GROUP BY LITERAL
134 let groups :: [[(Literal, EquationInfo)]]
135 groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
137 -- DO THE MATCHING FOR EACH GROUP
138 ; alts <- mapM match_group groups
140 -- MAKE THE PRIMITIVE CASE
141 ; return (mkCoPrimCaseMatchResult var ty alts) }
143 match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult)
145 = do { let (lits, eqns) = unzip group
146 ; match_result <- match vars ty (shiftEqns eqns)
147 ; return (head lits, match_result) }
150 %************************************************************************
152 Pattern matching on NPat
154 %************************************************************************
157 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
158 -- All the EquationInfos have NPatOut at the front
160 matchNPats (var:vars) ty eqns
161 = do { let groups :: [[(Literal, EquationInfo)]]
162 groups = equivClasses cmpTaggedEqn (tagLitEqns eqns)
164 ; match_results <- mapM (match_group . map snd) groups
166 ; ASSERT( not (null match_results) )
167 return (foldr1 combineMatchResults match_results) }
169 match_group :: [EquationInfo] -> DsM MatchResult
171 = do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var))
172 ; match_result <- match vars ty (shiftEqns eqns)
173 ; return (mkGuardedMatchResult pred_expr match_result) }
175 NPatOut _ _ eq_chk = firstPat (head eqns)
179 %************************************************************************
181 Pattern matching on n+k patterns
183 %************************************************************************
185 For an n+k pattern, we use the various magic expressions we've been given.
190 in <expr-for-a-successful-match>
192 <try-next-pattern-or-whatever>
201 We can't group the first and third together, because the second may match
202 the same thing as the first. Contrast
206 where we can group the first and third. Hence 'runs' rather than 'equivClasses'
209 matchNPlusKPats all_vars@(var:vars) ty eqns
210 = do { let groups :: [[(Literal, EquationInfo)]]
211 groups = runs eqTaggedEqn (tagLitEqns eqns)
213 ; match_results <- mapM (match_group . map snd) groups
215 ; ASSERT( not (null match_results) )
216 return (foldr1 combineMatchResults match_results) }
218 match_group :: [EquationInfo] -> DsM MatchResult
220 = do { ge_expr <- dsExpr (HsApp (noLoc ge) (nlHsVar var))
221 ; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var))
222 ; match_result <- match vars ty (shiftEqns eqns)
223 ; return (mkGuardedMatchResult ge_expr $
224 mkCoLetsMatchResult [NonRec n1 minusk_expr] $
225 bindInMatchResult (map line_up other_pats) $
228 (NPlusKPatOut (L _ n1) _ ge sub : other_pats) = map firstPat eqns
229 line_up (NPlusKPatOut (L _ n) _ _ _) = (n,n1)
233 %************************************************************************
237 %************************************************************************
239 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
240 that are ``same''/different as one we are looking at. We need to know
241 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
244 -- Tag equations by the leading literal
245 -- NB: we have ordering on Core Literals, but not on HsLits
246 cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering
247 cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2
249 eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool
250 eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2
252 tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)]
254 = [(get_lit eqn, eqn) | eqn <- eqns]
256 get_lit eqn = case firstPat eqn of
257 LitPat hs_lit -> mk_core_lit hs_lit
258 NPatOut hs_lit _ _ -> mk_core_lit hs_lit
259 NPlusKPatOut _ i _ _ -> MachInt i
260 other -> panic "tagLitEqns:bad pattern"
262 mk_core_lit :: HsLit -> Literal
263 mk_core_lit (HsIntPrim i) = mkMachInt i
264 mk_core_lit (HsCharPrim c) = MachChar c
265 mk_core_lit (HsStringPrim s) = MachStr s
266 mk_core_lit (HsFloatPrim f) = MachFloat f
267 mk_core_lit (HsDoublePrim d) = MachDouble d
269 -- These ones are only needed in the NPatOut case,
270 -- and the Literal is only used as a key for grouping,
271 -- so the type doesn't matter. Actually I think HsInt, HsChar
272 -- can't happen, but it does no harm to include them
273 mk_core_lit (HsString s) = MachStr s
274 mk_core_lit (HsRat r _) = MachFloat r
275 mk_core_lit (HsInteger i _) = MachInt i
276 mk_core_lit (HsInt i) = MachInt i
277 mk_core_lit (HsChar c) = MachChar c