Improve printing of "..." in HsExpr; fixes a stupidity in my earlier change
[ghc-hetmet.git] / compiler / deSugar / MatchLit.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 Pattern-matching literal patterns
7
8 \begin{code}
9 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
10                   tidyLitPat, tidyNPat, 
11                   matchLiterals, matchNPlusKPats, matchNPats ) where
12
13 #include "HsVersions.h"
14
15 import {-# SOURCE #-} Match  ( match )
16 import {-# SOURCE #-} DsExpr ( dsExpr )
17
18 import DsMonad
19 import DsUtils
20
21 import HsSyn
22 import Id
23 import CoreSyn
24 import TyCon
25 import DataCon
26 import TcType
27 import Type
28 import PrelNames
29 import TysWiredIn
30 import PrelNames
31 import Unique
32 import Literal
33 import SrcLoc
34 import Ratio
35 import SrcLoc
36 import Outputable
37 import Util
38 import FastString
39 \end{code}
40
41 %************************************************************************
42 %*                                                                      *
43                 Desugaring literals
44         [used to be in DsExpr, but DsMeta needs it,
45          and it's nice to avoid a loop]
46 %*                                                                      *
47 %************************************************************************
48
49 We give int/float literals type @Integer@ and @Rational@, respectively.
50 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
51 around them.
52
53 ToDo: put in range checks for when converting ``@i@''
54 (or should that be in the typechecker?)
55
56 For numeric literals, we try to detect there use at a standard type
57 (@Int@, @Float@, etc.) are directly put in the right constructor.
58 [NB: down with the @App@ conversion.]
59
60 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
61
62 \begin{code}
63 dsLit :: HsLit -> DsM CoreExpr
64 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
65 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
66 dsLit (HsIntPrim i)    = returnDs (mkLit (MachInt i))
67 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
68 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
69
70 dsLit (HsChar c)       = returnDs (mkCharExpr c)
71 dsLit (HsString str)   = mkStringExprFS str
72 dsLit (HsInteger i _)  = mkIntegerExpr i
73 dsLit (HsInt i)        = returnDs (mkIntExpr i)
74
75 dsLit (HsRat r ty)
76   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
77     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
78     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
79   where
80     (ratio_data_con, integer_ty) 
81         = case tcSplitTyConApp ty of
82                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
83                                    (head (tyConDataCons tycon), i_ty)
84
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
91 \end{code}
92
93 \begin{code}
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 (HsCharPrim    c) = MachChar   c
102 hsLitKey (HsStringPrim  s) = MachStr    s
103 hsLitKey (HsFloatPrim   f) = MachFloat  f
104 hsLitKey (HsDoublePrim  d) = MachDouble d
105 hsLitKey (HsString s)      = MachStr    s
106
107 hsOverLitKey :: HsOverLit a -> Bool -> Literal
108 -- Ditto for HsOverLit; the boolean indicates to negate
109 hsOverLitKey (HsIntegral i _) False   = MachInt i
110 hsOverLitKey (HsIntegral i _) True    = MachInt (-i)
111 hsOverLitKey (HsFractional r _) False = MachFloat r
112 hsOverLitKey (HsFractional r _) True  = MachFloat (-r)
113 hsOverLitKey (HsIsString s _)  False  = MachStr s
114 -- negated string should never happen
115 \end{code}
116
117 %************************************************************************
118 %*                                                                      *
119         Tidying lit pats
120 %*                                                                      *
121 %************************************************************************
122
123 \begin{code}
124 tidyLitPat :: HsLit -> Pat Id
125 -- Result has only the following HsLits:
126 --      HsIntPrim, HsCharPrim, HsFloatPrim
127 --      HsDoublePrim, HsStringPrim, HsString
128 --  * HsInteger, HsRat, HsInt can't show up in LitPats
129 --  * We get rid of HsChar right here
130 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
131 tidyLitPat (HsString s)
132   | lengthFS s <= 1     -- Short string literals only
133   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
134                   (mkNilPat stringTy) (unpackFS s)
135         -- The stringTy is the type of the whole pattern, not 
136         -- the type to instantiate (:) or [] with!
137 tidyLitPat lit = LitPat lit
138
139 ----------------
140 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
141          -> Type -> Pat Id
142 tidyNPat over_lit mb_neg eq lit_ty
143   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
144   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
145   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
146 --  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
147   | otherwise         = NPat over_lit mb_neg eq lit_ty
148   where
149     mk_con_pat :: DataCon -> HsLit -> Pat Id
150     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
151     neg_lit = case (mb_neg, over_lit) of
152                 (Nothing,              _)   -> over_lit
153                 (Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
154                 (Just _,  HsFractional f s) -> HsFractional (-f) s
155                              
156     int_val :: Integer
157     int_val = case neg_lit of
158                 HsIntegral   i _ -> i
159                 HsFractional f _ -> panic "tidyNPat"
160         
161     rat_val :: Rational
162     rat_val = case neg_lit of
163                 HsIntegral   i _ -> fromInteger i
164                 HsFractional f _ -> f
165         
166     str_val :: FastString
167     str_val = case neg_lit of
168                 HsIsString   s _ -> s
169                 _                -> error "tidyNPat"
170 \end{code}
171
172
173 %************************************************************************
174 %*                                                                      *
175                 Pattern matching on LitPat
176 %*                                                                      *
177 %************************************************************************
178
179 \begin{code}
180 matchLiterals :: [Id]
181               -> Type                   -- Type of the whole case expression
182               -> [[EquationInfo]]       -- All PgLits
183               -> DsM MatchResult
184
185 matchLiterals (var:vars) ty sub_groups
186   = ASSERT( all notNull sub_groups )
187     do  {       -- Deal with each group
188         ; alts <- mapM match_group sub_groups
189
190                 -- Combine results.  For everything except String
191                 -- we can use a case expression; for String we need
192                 -- a chain of if-then-else
193         ; if isStringTy (idType var) then
194             do  { eq_str <- dsLookupGlobalId eqStringName
195                 ; mrs <- mapM (wrap_str_guard eq_str) alts
196                 ; return (foldr1 combineMatchResults mrs) }
197           else 
198             return (mkCoPrimCaseMatchResult var ty alts)
199         }
200   where
201     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
202     match_group eqns
203         = do { let LitPat hs_lit = firstPat (head eqns)
204              ; match_result <- match vars ty (shiftEqns eqns)
205              ; return (hsLitKey hs_lit, match_result) }
206
207     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
208         -- Equality check for string literals
209     wrap_str_guard eq_str (MachStr s, mr)
210         = do { lit    <- mkStringExprFS s
211              ; let pred = mkApps (Var eq_str) [Var var, lit]
212              ; return (mkGuardedMatchResult pred mr) }
213 \end{code}
214
215
216 %************************************************************************
217 %*                                                                      *
218                 Pattern matching on NPat
219 %*                                                                      *
220 %************************************************************************
221
222 \begin{code}
223 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
224         -- All NPats, but perhaps for different literals
225 matchNPats vars ty groups
226   = do {  match_results <- mapM (matchOneNPat vars ty) groups
227         ; return (foldr1 combineMatchResults match_results) }
228
229 matchOneNPat (var:vars) ty (eqn1:eqns)  -- All for the same literal
230   = do  { let NPat lit mb_neg eq_chk _ = firstPat eqn1
231         ; lit_expr <- dsOverLit lit
232         ; neg_lit <- case mb_neg of
233                             Nothing -> return lit_expr
234                             Just neg -> do { neg_expr <- dsExpr neg
235                                            ; return (App neg_expr lit_expr) }
236         ; eq_expr <- dsExpr eq_chk
237         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
238         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
239         ; return (mkGuardedMatchResult pred_expr match_result) }
240 \end{code}
241
242
243 %************************************************************************
244 %*                                                                      *
245                 Pattern matching on n+k patterns
246 %*                                                                      *
247 %************************************************************************
248
249 For an n+k pattern, we use the various magic expressions we've been given.
250 We generate:
251 \begin{verbatim}
252     if ge var lit then
253         let n = sub var lit
254         in  <expr-for-a-successful-match>
255     else
256         <try-next-pattern-or-whatever>
257 \end{verbatim}
258
259
260 \begin{code}
261 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
262         -- All NPlusKPats, for the *same* literal k
263 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
264   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
265         ; ge_expr     <- dsExpr ge
266         ; minus_expr  <- dsExpr minus
267         ; lit_expr    <- dsOverLit lit
268         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
269               minusk_expr = mkApps minus_expr [Var var, lit_expr]
270               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
271         ; match_result <- match vars ty eqns'
272         ; return  (mkGuardedMatchResult pred_expr               $
273                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
274                    adjustMatchResult (foldr1 (.) wraps)         $
275                    match_result) }
276   where
277     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
278         = (wrapBind n n1, eqn { eqn_pats = pats })
279         -- The wrapBind is a no-op for the first equation
280 \end{code}