MatchLit.hs 19.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

Pattern-matching literal patterns
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9 10
{-# LANGUAGE CPP, ScopedTypeVariables #-}

11 12 13
module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
                , tidyLitPat, tidyNPat
                , matchLiterals, matchNPlusKPats, matchNPats
14
                , warnAboutIdentities, warnAboutEmptyEnumerations
15
                ) where
16

17 18 19
#include "HsVersions.h"

import {-# SOURCE #-} Match  ( match )
sof's avatar
sof committed
20
import {-# SOURCE #-} DsExpr ( dsExpr )
21

22
import DsMonad
23
import DsUtils
24

25
import HsSyn
26

Simon Marlow's avatar
Simon Marlow committed
27
import Id
28
import CoreSyn
29
import MkCore
Simon Marlow's avatar
Simon Marlow committed
30 31
import TyCon
import DataCon
32
import TcHsSyn ( shortCutLit )
Simon Marlow's avatar
Simon Marlow committed
33
import TcType
34 35
import Name
import Type
Simon Marlow's avatar
Simon Marlow committed
36 37 38 39
import PrelNames
import TysWiredIn
import Literal
import SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
40
import Data.Ratio
41
import Outputable
42
import BasicTypes
43
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
44 45
import Util
import FastString
46 47 48
import Control.Monad

import Data.Int
49
#if __GLASGOW_HASKELL__ < 709
50
import Data.Traversable (traverse)
51
#endif
52
import Data.Word
53

Austin Seipp's avatar
Austin Seipp committed
54 55 56
{-
************************************************************************
*                                                                      *
57 58 59
                Desugaring literals
        [used to be in DsExpr, but DsMeta needs it,
         and it's nice to avoid a loop]
Austin Seipp's avatar
Austin Seipp committed
60 61
*                                                                      *
************************************************************************
62 63 64 65 66 67 68 69 70 71 72 73 74

We give int/float literals type @Integer@ and @Rational@, respectively.
The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
around them.

ToDo: put in range checks for when converting ``@i@''
(or should that be in the typechecker?)

For numeric literals, we try to detect there use at a standard type
(@Int@, @Float@, etc.) are directly put in the right constructor.
[NB: down with the @App@ conversion.]

See also below where we look for @DictApps@ for \tr{plusInt}, etc.
Austin Seipp's avatar
Austin Seipp committed
75
-}
76 77

dsLit :: HsLit -> DsM CoreExpr
78 79 80 81 82 83 84 85 86 87 88 89 90 91
dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
dsLit (HsCharPrim   _ c) = return (Lit (MachChar c))
dsLit (HsIntPrim    _ i) = return (Lit (MachInt i))
dsLit (HsWordPrim   _ w) = return (Lit (MachWord w))
dsLit (HsInt64Prim  _ i) = return (Lit (MachInt64 i))
dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
dsLit (HsFloatPrim    f) = return (Lit (MachFloat (fl_value f)))
dsLit (HsDoublePrim   d) = return (Lit (MachDouble (fl_value d)))

dsLit (HsChar _ c)       = return (mkCharExpr c)
dsLit (HsString _ str)   = mkStringExprFS str
dsLit (HsInteger _ i _)  = mkIntegerExpr i
dsLit (HsInt _ i)        = do dflags <- getDynFlags
                              return (mkIntExpr dflags i)
92

93
dsLit (HsRat r ty) = do
94 95
   num   <- mkIntegerExpr (numerator (fl_value r))
   denom <- mkIntegerExpr (denominator (fl_value r))
96
   return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
97
  where
98
    (ratio_data_con, integer_ty)
99 100 101
        = case tcSplitTyConApp ty of
                (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
                                   (head (tyConDataCons tycon), i_ty)
Ian Lynagh's avatar
Ian Lynagh committed
102
                x -> pprPanic "dsLit" (ppr x)
103 104

dsOverLit :: HsOverLit Id -> DsM CoreExpr
105 106 107
dsOverLit lit = do { dflags <- getDynFlags
                   ; warnAboutOverflowedLiterals dflags lit
                   ; dsOverLit' dflags lit }
108 109

dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
110
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
111
-- (an expression for) the literal value itself
112 113
dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
                           , ol_witness = witness, ol_type = ty })
114
  | not rebindable
115 116
  , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]
  | otherwise                              = dsExpr witness
117

Austin Seipp's avatar
Austin Seipp committed
118
{-
119 120
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
121
The type checker tries to do this short-cutting as early as possible, but
Gabor Greif's avatar
typos  
Gabor Greif committed
122
because of unification etc, more information is available to the desugarer.
123
And where it's possible to generate the correct literal right away, it's
Gabor Greif's avatar
Gabor Greif committed
124
much better to do so.
125 126


Austin Seipp's avatar
Austin Seipp committed
127 128
************************************************************************
*                                                                      *
129
                 Warnings about overflowed literals
Austin Seipp's avatar
Austin Seipp committed
130 131
*                                                                      *
************************************************************************
132 133 134 135

Warn about functions like toInteger, fromIntegral, that convert
between one type and another when the to- and from- types are the
same.  Then it's probably (albeit not definitely) the identity
Austin Seipp's avatar
Austin Seipp committed
136
-}
137 138 139 140 141 142 143 144 145

warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
warnAboutIdentities dflags (Var conv_fn) type_of_conv
  | wopt Opt_WarnIdentities dflags
  , idName conv_fn `elem` conversionNames
  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
  = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
                 , nest 2 $ ptext (sLit "can probably be omitted")
Krzysztof Gogolewski's avatar
Typo  
Krzysztof Gogolewski committed
146
                 , parens (ptext (sLit "Use -fno-warn-identities to suppress this message"))
147 148 149 150 151 152 153 154 155
           ])
warnAboutIdentities _ _ _ = return ()

conversionNames :: [Name]
conversionNames
  = [ toIntegerName, toRationalName
    , fromIntegralName, realToFracName ]
 -- We can't easily add fromIntegerName, fromRationalName,
 -- because they are generated by literals
156

157 158 159 160
warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
warnAboutOverflowedLiterals dflags lit
 | wopt Opt_WarnOverflowedLiterals dflags
 , Just (i, tc) <- getIntegralLit lit
161 162 163 164 165 166 167 168 169 170
  = if      tc == intTyConName    then check i tc (undefined :: Int)
    else if tc == int8TyConName   then check i tc (undefined :: Int8)
    else if tc == int16TyConName  then check i tc (undefined :: Int16)
    else if tc == int32TyConName  then check i tc (undefined :: Int32)
    else if tc == int64TyConName  then check i tc (undefined :: Int64)
    else if tc == wordTyConName   then check i tc (undefined :: Word)
    else if tc == word8TyConName  then check i tc (undefined :: Word8)
    else if tc == word16TyConName then check i tc (undefined :: Word16)
    else if tc == word32TyConName then check i tc (undefined :: Word32)
    else if tc == word64TyConName then check i tc (undefined :: Word64)
171 172 173
    else return ()

  | otherwise = return ()
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
  where
    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()
    check i tc _proxy
      = when (i < minB || i > maxB) $ do
        warnDs (vcat [ ptext (sLit "Literal") <+> integer i
                       <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range")
                       <+> integer minB <> ptext (sLit "..") <> integer maxB
                     , sug ])
      where
        minB = toInteger (minBound :: a)
        maxB = toInteger (maxBound :: a)
        sug | minB == -i   -- Note [Suggest NegativeLiterals]
            , i > 0
            , not (xopt Opt_NegativeLiterals dflags)
            = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")
189
            | otherwise = Outputable.empty
190

Austin Seipp's avatar
Austin Seipp committed
191
{-
192 193 194 195 196 197 198 199 200
Note [Suggest NegativeLiterals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you write
  x :: Int8
  x = -128
it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
We get an erroneous suggestion for
  x = 128
but perhaps that does not matter too much.
Austin Seipp's avatar
Austin Seipp committed
201
-}
202

203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()
-- Warns about [2,3 .. 1] which returns the empty list
-- Only works for integral types, not floating point
warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
  | wopt Opt_WarnEmptyEnumerations dflags
  , Just (from,tc) <- getLHsIntegralLit fromExpr
  , Just mThn      <- traverse getLHsIntegralLit mThnExpr
  , Just (to,_)    <- getLHsIntegralLit toExpr
  , let check :: forall a. (Enum a, Num a) => a -> DsM ()
        check _proxy
          = when (null enumeration) $
            warnDs (ptext (sLit "Enumeration is empty"))
          where
            enumeration :: [a]
            enumeration = case mThn of
                            Nothing      -> [fromInteger from                    .. fromInteger to]
                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]

  = if      tc == intTyConName    then check (undefined :: Int)
    else if tc == int8TyConName   then check (undefined :: Int8)
    else if tc == int16TyConName  then check (undefined :: Int16)
    else if tc == int32TyConName  then check (undefined :: Int32)
    else if tc == int64TyConName  then check (undefined :: Int64)
    else if tc == wordTyConName   then check (undefined :: Word)
    else if tc == word8TyConName  then check (undefined :: Word8)
    else if tc == word16TyConName then check (undefined :: Word16)
    else if tc == word32TyConName then check (undefined :: Word32)
    else if tc == word64TyConName then check (undefined :: Word64)
    else return ()

  | otherwise = return ()

getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)
236 237 238 239 240
-- See if the expression is an Integral literal
-- Remember to look through automatically-added tick-boxes! (Trac #8384)
getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e
241 242 243 244
getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
getLHsIntegralLit _ = Nothing

getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
245
getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty })
246 247 248 249
  | Just tc <- tyConAppTyCon_maybe ty
  = Just (i, tyConName tc)
getIntegralLit _ = Nothing

Austin Seipp's avatar
Austin Seipp committed
250 251 252
{-
************************************************************************
*                                                                      *
253
        Tidying lit pats
Austin Seipp's avatar
Austin Seipp committed
254 255 256
*                                                                      *
************************************************************************
-}
257

258
tidyLitPat :: HsLit -> Pat Id
259
-- Result has only the following HsLits:
260 261
--      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
--      HsDoublePrim, HsStringPrim, HsString
262 263
--  * HsInteger, HsRat, HsInt can't show up in LitPats
--  * We get rid of HsChar right here
264 265
tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
tidyLitPat (HsString src s)
266
  | lengthFS s <= 1     -- Short string literals only
267 268
  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
                                             [mkCharLitPat src c, pat] [charTy])
269
                  (mkNilPat charTy) (unpackFS s)
270 271
        -- The stringTy is the type of the whole pattern, not
        -- the type to instantiate (:) or [] with!
272
tidyLitPat lit = LitPat lit
273

274
----------------
275 276 277 278 279 280
tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat
                 -- We need this argument because tidyNPat is called
                 -- both by Match and by Check, but they tidy LitPats
                 -- slightly differently; and we must desugar
                 -- literals consistently (see Trac #5117)
         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
281 282
         -> Pat Id
tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
283 284 285 286 287
        -- False: Take short cuts only if the literal is not using rebindable syntax
        --
        -- Once that is settled, look for cases where the type of the
        -- entire overloaded literal matches the type of the underlying literal,
        -- and in that case take the short cut
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
288
        -- NB: Watch out for weird cases like Trac #3382
289 290 291 292
        --        f :: Int -> Int
        --        f "blah" = 4
        --     which might be ok if we hvae 'instance IsString Int'
        --
293

294 295 296 297
  | isIntTy ty,    Just int_lit <- mb_int_lit
                            = mk_con_pat intDataCon    (HsIntPrim    "" int_lit)
  | isWordTy ty,   Just int_lit <- mb_int_lit
                            = mk_con_pat wordDataCon   (HsWordPrim   "" int_lit)
298 299
  | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
  | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
300 301
  | isStringTy ty, Just str_lit <- mb_str_lit
                            = tidy_lit_pat (HsString "" str_lit)
302
  where
303
    mk_con_pat :: DataCon -> HsLit -> Pat Id
304
    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
305

306 307
    mb_int_lit :: Maybe Integer
    mb_int_lit = case (mb_neg, val) of
308 309
                   (Nothing, HsIntegral _ i) -> Just i
                   (Just _,  HsIntegral _ i) -> Just (-i)
310 311
                   _ -> Nothing

312
    mb_rat_lit :: Maybe FractionalLit
313
    mb_rat_lit = case (mb_neg, val) of
314 315 316 317 318 319
       (Nothing, HsIntegral _ i) -> Just (integralFractionalLit (fromInteger i))
       (Just _,  HsIntegral _ i) -> Just (integralFractionalLit
                                                             (fromInteger (-i)))
       (Nothing, HsFractional f) -> Just f
       (Just _, HsFractional f)  -> Just (negateFractionalLit f)
       _ -> Nothing
320

321 322
    mb_str_lit :: Maybe FastString
    mb_str_lit = case (mb_neg, val) of
323
                   (Nothing, HsIsString _ s) -> Just s
324
                   _ -> Nothing
325

326
tidyNPat _ over_lit mb_neg eq
Alan Zimmerman's avatar
Alan Zimmerman committed
327
  = NPat (noLoc over_lit) mb_neg eq
328

Austin Seipp's avatar
Austin Seipp committed
329 330 331
{-
************************************************************************
*                                                                      *
332
                Pattern matching on LitPat
Austin Seipp's avatar
Austin Seipp committed
333 334 335
*                                                                      *
************************************************************************
-}
336

337
matchLiterals :: [Id]
338 339 340
              -> Type                   -- Type of the whole case expression
              -> [[EquationInfo]]       -- All PgLits
              -> DsM MatchResult
341

342
matchLiterals (var:vars) ty sub_groups
343
  = ASSERT( notNull sub_groups && all notNull sub_groups )
344 345 346 347 348 349 350 351 352 353 354 355 356
    do  {       -- Deal with each group
        ; alts <- mapM match_group sub_groups

                -- Combine results.  For everything except String
                -- we can use a case expression; for String we need
                -- a chain of if-then-else
        ; if isStringTy (idType var) then
            do  { eq_str <- dsLookupGlobalId eqStringName
                ; mrs <- mapM (wrap_str_guard eq_str) alts
                ; return (foldr1 combineMatchResults mrs) }
          else
            return (mkCoPrimCaseMatchResult var ty alts)
        }
357
  where
358 359
    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
    match_group eqns
360 361 362 363
        = do dflags <- getDynFlags
             let LitPat hs_lit = firstPat (head eqns)
             match_result <- match vars ty (shiftEqns eqns)
             return (hsLitKey dflags hs_lit, match_result)
364

365
    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
366
        -- Equality check for string literals
367
    wrap_str_guard eq_str (MachStr s, mr)
368 369
        = do { -- We now have to convert back to FastString. Perhaps there
               -- should be separate MachBytes and MachStr constructors?
370
               let s'  = mkFastStringByteString s
371 372 373
             ; lit    <- mkStringExprFS s'
             ; let pred = mkApps (Var eq_str) [Var var, lit]
             ; return (mkGuardedMatchResult pred mr) }
Ian Lynagh's avatar
Ian Lynagh committed
374 375 376
    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)

matchLiterals [] _ _ = panic "matchLiterals []"
377

378 379 380 381 382 383 384
---------------------------
hsLitKey :: DynFlags -> HsLit -> Literal
-- Get a Core literal to use (only) a grouping key
-- Hence its type doesn't need to match the type of the original literal
--      (and doesn't for strings)
-- It only works for primitive types and strings;
-- others have been removed by tidy
385 386 387 388 389 390 391 392 393 394
hsLitKey dflags (HsIntPrim    _ i) = mkMachInt  dflags i
hsLitKey dflags (HsWordPrim   _ w) = mkMachWord dflags w
hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64  i
hsLitKey _      (HsWord64Prim _ w) = mkMachWord64 w
hsLitKey _      (HsCharPrim   _ c) = MachChar   c
hsLitKey _      (HsStringPrim _ s) = MachStr    s
hsLitKey _      (HsFloatPrim    f) = MachFloat  (fl_value f)
hsLitKey _      (HsDoublePrim   d) = MachDouble (fl_value d)
hsLitKey _      (HsString _ s)     = MachStr    (fastStringToByteString s)
hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
395 396

---------------------------
397
hsOverLitKey :: HsOverLit a -> Bool -> Literal
398 399 400 401 402
-- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg

---------------------------
litValKey :: OverLitVal -> Bool -> Literal
403 404
litValKey (HsIntegral _ i) False = MachInt i
litValKey (HsIntegral _ i) True  = MachInt (-i)
405 406
litValKey (HsFractional r) False = MachFloat (fl_value r)
litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
407 408
litValKey (HsIsString _ s) neg   = ASSERT( not neg) MachStr
                                                      (fastStringToByteString s)
409

Austin Seipp's avatar
Austin Seipp committed
410 411 412
{-
************************************************************************
*                                                                      *
413
                Pattern matching on NPat
Austin Seipp's avatar
Austin Seipp committed
414 415 416
*                                                                      *
************************************************************************
-}
417

418
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
419
matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
Alan Zimmerman's avatar
Alan Zimmerman committed
420
  = do  { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1
421 422 423 424 425 426 427 428 429
        ; lit_expr <- dsOverLit lit
        ; neg_lit <- case mb_neg of
                            Nothing -> return lit_expr
                            Just neg -> do { neg_expr <- dsExpr neg
                                           ; return (App neg_expr lit_expr) }
        ; eq_expr <- dsExpr eq_chk
        ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
        ; return (mkGuardedMatchResult pred_expr match_result) }
430
matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
431

Austin Seipp's avatar
Austin Seipp committed
432 433 434
{-
************************************************************************
*                                                                      *
435
                Pattern matching on n+k patterns
Austin Seipp's avatar
Austin Seipp committed
436 437
*                                                                      *
************************************************************************
438

439 440 441 442
For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
    if ge var lit then
443 444
        let n = sub var lit
        in  <expr-for-a-successful-match>
445
    else
446
        <try-next-pattern-or-whatever>
447
\end{verbatim}
Austin Seipp's avatar
Austin Seipp committed
448
-}
449

450
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
Ian Lynagh's avatar
Ian Lynagh committed
451 452
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
Alan Zimmerman's avatar
Alan Zimmerman committed
453
  = do  { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1
454 455 456 457 458 459 460 461 462 463 464
        ; ge_expr     <- dsExpr ge
        ; minus_expr  <- dsExpr minus
        ; lit_expr    <- dsOverLit lit
        ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
              minusk_expr = mkApps minus_expr [Var var, lit_expr]
              (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
        ; match_result <- match vars ty eqns'
        ; return  (mkGuardedMatchResult pred_expr               $
                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $
                   adjustMatchResult (foldr1 (.) wraps)         $
                   match_result) }
465
  where
466
    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
467 468
        = (wrapBind n n1, eqn { eqn_pats = pats })
        -- The wrapBind is a no-op for the first equation
Ian Lynagh's avatar
Ian Lynagh committed
469 470 471
    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)

matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))