Make Applicative a superclass of Monad
[ghc.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 {-# LANGUAGE CPP, ScopedTypeVariables #-}
10
11 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
12                 , tidyLitPat, tidyNPat
13                 , matchLiterals, matchNPlusKPats, matchNPats
14                 , warnAboutIdentities, warnAboutEmptyEnumerations 
15                 ) where
16
17 #include "HsVersions.h"
18
19 import {-# SOURCE #-} Match  ( match )
20 import {-# SOURCE #-} DsExpr ( dsExpr )
21
22 import DsMonad
23 import DsUtils
24
25 import HsSyn
26
27 import Id
28 import CoreSyn
29 import MkCore
30 import TyCon
31 import DataCon
32 import TcHsSyn ( shortCutLit )
33 import TcType
34 import Name
35 import Type
36 import PrelNames
37 import TysWiredIn
38 import Literal
39 import SrcLoc
40 import Data.Ratio
41 import Outputable
42 import BasicTypes
43 import DynFlags
44 import Util
45 import FastString
46 import Control.Monad
47
48 import Data.Int
49 import Data.Traversable (traverse)
50 import Data.Word
51 \end{code}
52
53 %************************************************************************
54 %*                                                                      *
55                 Desugaring literals
56         [used to be in DsExpr, but DsMeta needs it,
57          and it's nice to avoid a loop]
58 %*                                                                      *
59 %************************************************************************
60
61 We give int/float literals type @Integer@ and @Rational@, respectively.
62 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
63 around them.
64
65 ToDo: put in range checks for when converting ``@i@''
66 (or should that be in the typechecker?)
67
68 For numeric literals, we try to detect there use at a standard type
69 (@Int@, @Float@, etc.) are directly put in the right constructor.
70 [NB: down with the @App@ conversion.]
71
72 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
73
74 \begin{code}
75 dsLit :: HsLit -> DsM CoreExpr
76 dsLit (HsStringPrim s) = return (Lit (MachStr s))
77 dsLit (HsCharPrim   c) = return (Lit (MachChar c))
78 dsLit (HsIntPrim    i) = return (Lit (MachInt i))
79 dsLit (HsWordPrim   w) = return (Lit (MachWord w))
80 dsLit (HsInt64Prim  i) = return (Lit (MachInt64 i))
81 dsLit (HsWord64Prim w) = return (Lit (MachWord64 w))
82 dsLit (HsFloatPrim  f) = return (Lit (MachFloat (fl_value f)))
83 dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
84
85 dsLit (HsChar c)       = return (mkCharExpr c)
86 dsLit (HsString str)   = mkStringExprFS str
87 dsLit (HsInteger i _)  = mkIntegerExpr i
88 dsLit (HsInt i)        = do dflags <- getDynFlags
89                             return (mkIntExpr dflags i)
90
91 dsLit (HsRat r ty) = do
92    num   <- mkIntegerExpr (numerator (fl_value r))
93    denom <- mkIntegerExpr (denominator (fl_value r))
94    return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
95   where
96     (ratio_data_con, integer_ty)
97         = case tcSplitTyConApp ty of
98                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
99                                    (head (tyConDataCons tycon), i_ty)
100                 x -> pprPanic "dsLit" (ppr x)
101
102 dsOverLit :: HsOverLit Id -> DsM CoreExpr
103 dsOverLit lit = do { dflags <- getDynFlags
104                    ; warnAboutOverflowedLiterals dflags lit
105                    ; dsOverLit' dflags lit }
106
107 dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
108 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
109 -- (an expression for) the literal value itself
110 dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
111                            , ol_witness = witness, ol_type = ty })
112   | not rebindable
113   , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]
114   | otherwise                              = dsExpr witness
115 \end{code}
116
117 Note [Literal short cut]
118 ~~~~~~~~~~~~~~~~~~~~~~~~
119 The type checker tries to do this short-cutting as early as possible, but
120 because of unification etc, more information is available to the desugarer.
121 And where it's possible to generate the correct literal right away, it's
122 much better to do so.
123
124
125 %************************************************************************
126 %*                                                                      *
127                  Warnings about overflowed literals
128 %*                                                                      *
129 %************************************************************************
130
131 Warn about functions like toInteger, fromIntegral, that convert
132 between one type and another when the to- and from- types are the
133 same.  Then it's probably (albeit not definitely) the identity
134
135 \begin{code}
136 warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
137 warnAboutIdentities dflags (Var conv_fn) type_of_conv
138   | wopt Opt_WarnIdentities dflags
139   , idName conv_fn `elem` conversionNames
140   , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
141   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
142   = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
143                  , nest 2 $ ptext (sLit "can probably be omitted")
144                  , parens (ptext (sLit "Use -fno-warn-identities to suppress this message"))
145            ])
146 warnAboutIdentities _ _ _ = return ()
147
148 conversionNames :: [Name]
149 conversionNames
150   = [ toIntegerName, toRationalName
151     , fromIntegralName, realToFracName ]
152  -- We can't easily add fromIntegerName, fromRationalName,
153  -- because they are generated by literals
154 \end{code}
155
156 \begin{code}
157 warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
158 warnAboutOverflowedLiterals dflags lit
159  | wopt Opt_WarnOverflowedLiterals dflags
160  , Just (i, tc) <- getIntegralLit lit
161   = if      tc == intTyConName    then check i tc (undefined :: Int)
162     else if tc == int8TyConName   then check i tc (undefined :: Int8)
163     else if tc == int16TyConName  then check i tc (undefined :: Int16)
164     else if tc == int32TyConName  then check i tc (undefined :: Int32)
165     else if tc == int64TyConName  then check i tc (undefined :: Int64)
166     else if tc == wordTyConName   then check i tc (undefined :: Word)
167     else if tc == word8TyConName  then check i tc (undefined :: Word8)
168     else if tc == word16TyConName then check i tc (undefined :: Word16)
169     else if tc == word32TyConName then check i tc (undefined :: Word32)
170     else if tc == word64TyConName then check i tc (undefined :: Word64)
171     else return ()
172
173   | otherwise = return ()
174   where
175     check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()
176     check i tc _proxy
177       = when (i < minB || i > maxB) $ do
178         warnDs (vcat [ ptext (sLit "Literal") <+> integer i
179                        <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range")
180                        <+> integer minB <> ptext (sLit "..") <> integer maxB
181                      , sug ])
182       where
183         minB = toInteger (minBound :: a)
184         maxB = toInteger (maxBound :: a)
185         sug | minB == -i   -- Note [Suggest NegativeLiterals]
186             , i > 0
187             , not (xopt Opt_NegativeLiterals dflags)
188             = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")
189             | otherwise = Outputable.empty
190 \end{code}
191
192 Note [Suggest NegativeLiterals]
193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
194 If you write
195   x :: Int8
196   x = -128
197 it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
198 We get an erroneous suggestion for
199   x = 128
200 but perhaps that does not matter too much.
201
202 \begin{code}
203 warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()
204 -- Warns about [2,3 .. 1] which returns the empty list
205 -- Only works for integral types, not floating point
206 warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
207   | wopt Opt_WarnEmptyEnumerations dflags
208   , Just (from,tc) <- getLHsIntegralLit fromExpr
209   , Just mThn      <- traverse getLHsIntegralLit mThnExpr
210   , Just (to,_)    <- getLHsIntegralLit toExpr
211   , let check :: forall a. (Enum a, Num a) => a -> DsM ()
212         check _proxy
213           = when (null enumeration) $
214             warnDs (ptext (sLit "Enumeration is empty"))
215           where
216             enumeration :: [a]
217             enumeration = case mThn of
218                             Nothing      -> [fromInteger from                    .. fromInteger to]
219                             Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]
220
221   = if      tc == intTyConName    then check (undefined :: Int)
222     else if tc == int8TyConName   then check (undefined :: Int8)
223     else if tc == int16TyConName  then check (undefined :: Int16)
224     else if tc == int32TyConName  then check (undefined :: Int32)
225     else if tc == int64TyConName  then check (undefined :: Int64)
226     else if tc == wordTyConName   then check (undefined :: Word)
227     else if tc == word8TyConName  then check (undefined :: Word8)
228     else if tc == word16TyConName then check (undefined :: Word16)
229     else if tc == word32TyConName then check (undefined :: Word32)
230     else if tc == word64TyConName then check (undefined :: Word64)
231     else return ()
232
233   | otherwise = return ()
234
235 getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)
236 -- See if the expression is an Integral literal
237 -- Remember to look through automatically-added tick-boxes! (Trac #8384)
238 getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e
239 getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e
240 getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e
241 getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
242 getLHsIntegralLit _ = Nothing
243
244 getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
245 getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
246   | Just tc <- tyConAppTyCon_maybe ty
247   = Just (i, tyConName tc)
248 getIntegralLit _ = Nothing
249 \end{code}
250
251
252 %************************************************************************
253 %*                                                                      *
254         Tidying lit pats
255 %*                                                                      *
256 %************************************************************************
257
258 \begin{code}
259 tidyLitPat :: HsLit -> Pat Id
260 -- Result has only the following HsLits:
261 --      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
262 --      HsDoublePrim, HsStringPrim, HsString
263 --  * HsInteger, HsRat, HsInt can't show up in LitPats
264 --  * We get rid of HsChar right here
265 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
266 tidyLitPat (HsString s)
267   | lengthFS s <= 1     -- Short string literals only
268   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
269                   (mkNilPat charTy) (unpackFS s)
270         -- The stringTy is the type of the whole pattern, not
271         -- the type to instantiate (:) or [] with!
272 tidyLitPat lit = LitPat lit
273
274 ----------------
275 tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat
276                  -- We need this argument because tidyNPat is called
277                  -- both by Match and by Check, but they tidy LitPats
278                  -- slightly differently; and we must desugar
279                  -- literals consistently (see Trac #5117)
280          -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
281          -> Pat Id
282 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
283         -- False: Take short cuts only if the literal is not using rebindable syntax
284         --
285         -- Once that is settled, look for cases where the type of the
286         -- entire overloaded literal matches the type of the underlying literal,
287         -- and in that case take the short cut
288         -- NB: Watch out for weird cases like Trac #3382
289         --        f :: Int -> Int
290         --        f "blah" = 4
291         --     which might be ok if we hvae 'instance IsString Int'
292         --
293
294   | isIntTy ty,    Just int_lit <- mb_int_lit = mk_con_pat intDataCon    (HsIntPrim    int_lit)
295   | isWordTy ty,   Just int_lit <- mb_int_lit = mk_con_pat wordDataCon   (HsWordPrim   int_lit)
296   | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
297   | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
298   | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
299   where
300     mk_con_pat :: DataCon -> HsLit -> Pat Id
301     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
302
303     mb_int_lit :: Maybe Integer
304     mb_int_lit = case (mb_neg, val) of
305                    (Nothing, HsIntegral i) -> Just i
306                    (Just _,  HsIntegral i) -> Just (-i)
307                    _ -> Nothing
308
309     mb_rat_lit :: Maybe FractionalLit
310     mb_rat_lit = case (mb_neg, val) of
311                    (Nothing, HsIntegral   i) -> Just (integralFractionalLit (fromInteger i))
312                    (Just _,  HsIntegral   i) -> Just (integralFractionalLit (fromInteger (-i)))
313                    (Nothing, HsFractional f) -> Just f
314                    (Just _, HsFractional f)  -> Just (negateFractionalLit f)
315                    _ -> Nothing
316
317     mb_str_lit :: Maybe FastString
318     mb_str_lit = case (mb_neg, val) of
319                    (Nothing, HsIsString s) -> Just s
320                    _ -> Nothing
321
322 tidyNPat _ over_lit mb_neg eq
323   = NPat over_lit mb_neg eq
324 \end{code}
325
326
327 %************************************************************************
328 %*                                                                      *
329                 Pattern matching on LitPat
330 %*                                                                      *
331 %************************************************************************
332
333 \begin{code}
334 matchLiterals :: [Id]
335               -> Type                   -- Type of the whole case expression
336               -> [[EquationInfo]]       -- All PgLits
337               -> DsM MatchResult
338
339 matchLiterals (var:vars) ty sub_groups
340   = ASSERT( notNull sub_groups && all notNull sub_groups )
341     do  {       -- Deal with each group
342         ; alts <- mapM match_group sub_groups
343
344                 -- Combine results.  For everything except String
345                 -- we can use a case expression; for String we need
346                 -- a chain of if-then-else
347         ; if isStringTy (idType var) then
348             do  { eq_str <- dsLookupGlobalId eqStringName
349                 ; mrs <- mapM (wrap_str_guard eq_str) alts
350                 ; return (foldr1 combineMatchResults mrs) }
351           else
352             return (mkCoPrimCaseMatchResult var ty alts)
353         }
354   where
355     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
356     match_group eqns
357         = do dflags <- getDynFlags
358              let LitPat hs_lit = firstPat (head eqns)
359              match_result <- match vars ty (shiftEqns eqns)
360              return (hsLitKey dflags hs_lit, match_result)
361
362     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
363         -- Equality check for string literals
364     wrap_str_guard eq_str (MachStr s, mr)
365         = do { -- We now have to convert back to FastString. Perhaps there
366                -- should be separate MachBytes and MachStr constructors?
367                let s'  = mkFastStringByteString s
368              ; lit    <- mkStringExprFS s'
369              ; let pred = mkApps (Var eq_str) [Var var, lit]
370              ; return (mkGuardedMatchResult pred mr) }
371     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
372
373 matchLiterals [] _ _ = panic "matchLiterals []"
374
375 ---------------------------
376 hsLitKey :: DynFlags -> HsLit -> Literal
377 -- Get a Core literal to use (only) a grouping key
378 -- Hence its type doesn't need to match the type of the original literal
379 --      (and doesn't for strings)
380 -- It only works for primitive types and strings;
381 -- others have been removed by tidy
382 hsLitKey dflags (HsIntPrim     i) = mkMachInt  dflags i
383 hsLitKey dflags (HsWordPrim    w) = mkMachWord dflags w
384 hsLitKey _      (HsInt64Prim   i) = mkMachInt64  i
385 hsLitKey _      (HsWord64Prim  w) = mkMachWord64 w
386 hsLitKey _      (HsCharPrim    c) = MachChar   c
387 hsLitKey _      (HsStringPrim  s) = MachStr    s
388 hsLitKey _      (HsFloatPrim   f) = MachFloat  (fl_value f)
389 hsLitKey _      (HsDoublePrim  d) = MachDouble (fl_value d)
390 hsLitKey _      (HsString s)      = MachStr    (fastStringToByteString s)
391 hsLitKey _      l                 = pprPanic "hsLitKey" (ppr l)
392
393 ---------------------------
394 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
395 -- Ditto for HsOverLit; the boolean indicates to negate
396 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
397
398 ---------------------------
399 litValKey :: OverLitVal -> Bool -> Literal
400 litValKey (HsIntegral i)   False = MachInt i
401 litValKey (HsIntegral i)   True  = MachInt (-i)
402 litValKey (HsFractional r) False = MachFloat (fl_value r)
403 litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
404 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr (fastStringToByteString s)
405 \end{code}
406
407 %************************************************************************
408 %*                                                                      *
409                 Pattern matching on NPat
410 %*                                                                      *
411 %************************************************************************
412
413 \begin{code}
414 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
415 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
416   = do  { let NPat lit mb_neg eq_chk = firstPat eqn1
417         ; lit_expr <- dsOverLit lit
418         ; neg_lit <- case mb_neg of
419                             Nothing -> return lit_expr
420                             Just neg -> do { neg_expr <- dsExpr neg
421                                            ; return (App neg_expr lit_expr) }
422         ; eq_expr <- dsExpr eq_chk
423         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
424         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
425         ; return (mkGuardedMatchResult pred_expr match_result) }
426 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
427 \end{code}
428
429
430 %************************************************************************
431 %*                                                                      *
432                 Pattern matching on n+k patterns
433 %*                                                                      *
434 %************************************************************************
435
436 For an n+k pattern, we use the various magic expressions we've been given.
437 We generate:
438 \begin{verbatim}
439     if ge var lit then
440         let n = sub var lit
441         in  <expr-for-a-successful-match>
442     else
443         <try-next-pattern-or-whatever>
444 \end{verbatim}
445
446
447 \begin{code}
448 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
449 -- All NPlusKPats, for the *same* literal k
450 matchNPlusKPats (var:vars) ty (eqn1:eqns)
451   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
452         ; ge_expr     <- dsExpr ge
453         ; minus_expr  <- dsExpr minus
454         ; lit_expr    <- dsOverLit lit
455         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
456               minusk_expr = mkApps minus_expr [Var var, lit_expr]
457               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
458         ; match_result <- match vars ty eqns'
459         ; return  (mkGuardedMatchResult pred_expr               $
460                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
461                    adjustMatchResult (foldr1 (.) wraps)         $
462                    match_result) }
463   where
464     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
465         = (wrapBind n n1, eqn { eqn_pats = pats })
466         -- The wrapBind is a no-op for the first equation
467     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
468
469 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
470 \end{code}