MatchLit.hs 19.2 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
module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey
12 13
                , tidyLitPat, tidyNPat
                , matchLiterals, matchNPlusKPats, matchNPats
14 15
                , warnAboutIdentities, warnAboutOverflowedLiterals
                , warnAboutEmptyEnumerations
16
                ) where
17

18 19 20
#include "HsVersions.h"

import {-# SOURCE #-} Match  ( match )
21
import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
22

23
import DsMonad
24
import DsUtils
25

26
import HsSyn
27

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

49
import Control.Monad
50 51
import Data.Int
import Data.Word
52

Austin Seipp's avatar
Austin Seipp committed
53 54 55
{-
************************************************************************
*                                                                      *
56 57 58
                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
59 60
*                                                                      *
************************************************************************
61 62 63 64 65 66 67 68 69 70 71 72 73

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
74
-}
75 76

dsLit :: HsLit -> DsM CoreExpr
77 78 79 80 81 82 83 84 85 86 87
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
88 89
dsLit (HsInt i)          = do dflags <- getDynFlags
                              return (mkIntExpr dflags (il_value i))
90

91 92 93 94
dsLit (HsRat (FL _ _ val) ty) = do
  num   <- mkIntegerExpr (numerator val)
  denom <- mkIntegerExpr (denominator val)
  return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
95
  where
96
    (ratio_data_con, integer_ty)
97 98 99
        = 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
100
                x -> pprPanic "dsLit" (ppr x)
101 102

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

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

Austin Seipp's avatar
Austin Seipp committed
116
{-
117 118
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
119
The type checker tries to do this short-cutting as early as possible, but
Gabor Greif's avatar
typos  
Gabor Greif committed
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
Gabor Greif's avatar
Gabor Greif committed
122
much better to do so.
123 124


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

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
134
-}
135 136 137 138 139 140 141

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
142 143
  = warnDs (Reason Opt_WarnIdentities)
           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
144
                 , nest 2 $ text "can probably be omitted"
145 146 147 148 149 150 151 152 153
           ])
warnAboutIdentities _ _ _ = return ()

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

155 156 157 158
warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
warnAboutOverflowedLiterals dflags lit
 | wopt Opt_WarnOverflowedLiterals dflags
 , Just (i, tc) <- getIntegralLit lit
159 160 161 162 163 164 165 166 167 168
  = 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)
169 170 171
    else return ()

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

Austin Seipp's avatar
Austin Seipp committed
190
{-
191 192 193 194 195 196 197 198 199
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
200
-}
201

202 203 204 205 206 207 208 209 210 211 212
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) $
213
            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
          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)
230
    else if tc == integerTyConName then check (undefined :: Integer)
231 232 233 234 235
    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
  | Just tc <- tyConAppTyCon_maybe ty
247
  = Just (il_value i, tyConName tc)
248 249
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
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)
280
         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type
281
         -> Pat Id
282
tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
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
        --        f :: Int -> Int
        --        f "blah" = 4
291
        --     which might be ok if we have 'instance IsString Int'
292
        --
293
  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
Alan Zimmerman's avatar
Alan Zimmerman committed
294
                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
295
  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
Alan Zimmerman's avatar
Alan Zimmerman committed
296
                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
297
  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
Alan Zimmerman's avatar
Alan Zimmerman committed
298
                 = tidy_lit_pat (HsString NoSourceText str_lit)
Ben Gamari's avatar
Ben Gamari committed
299 300 301 302
     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
     -- If we do convert to the constructor form, we'll generate a case
     -- expression on a Float# or Double# and that's not allowed in Core; see
     -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
303
  where
304 305 306 307 308 309
    -- Sometimes (like in test case
    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
    -- type-changing wrappers (for example, from Id Int to Int, for the identity
    -- type family Id). In these cases, we can't do the short-cut.
    type_change = not (outer_ty `eqType` ty)

310
    mk_con_pat :: DataCon -> HsLit -> Pat Id
311
    mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
312

313 314
    mb_int_lit :: Maybe Integer
    mb_int_lit = case (mb_neg, val) of
315 316
                   (Nothing, HsIntegral i) -> Just (il_value i)
                   (Just _,  HsIntegral i) -> Just (-(il_value i))
317 318
                   _ -> Nothing

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

324 325
tidyNPat _ over_lit mb_neg eq outer_ty
  = NPat (noLoc over_lit) mb_neg eq outer_ty
326

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

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

340
matchLiterals (var:vars) ty sub_groups
341
  = ASSERT( notNull sub_groups && all notNull sub_groups )
342 343 344 345 346 347 348 349 350 351 352 353 354
    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)
        }
355
  where
356 357
    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
    match_group eqns
358 359 360 361
        = do dflags <- getDynFlags
             let LitPat hs_lit = firstPat (head eqns)
             match_result <- match vars ty (shiftEqns eqns)
             return (hsLitKey dflags hs_lit, match_result)
362

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

matchLiterals [] _ _ = panic "matchLiterals []"
375

376 377
---------------------------
hsLitKey :: DynFlags -> HsLit -> Literal
378
-- Get the Core literal corresponding to a HsLit.
379 380
-- It only works for primitive types and strings;
-- others have been removed by tidy
381 382 383 384 385 386 387 388 389 390 391 392 393 394
-- For HsString, it produces a MachStr, which really represents an _unboxed_
-- string literal; and we deal with it in matchLiterals above. Otherwise, it
-- produces a primitive Literal of type matching the original HsLit.
-- In the case of the fixed-width numeric types, we need to wrap here
-- because Literal has an invariant that the literal is in range, while
-- HsLit does not.
hsLitKey dflags (HsIntPrim    _ i) = mkMachIntWrap  dflags i
hsLitKey dflags (HsWordPrim   _ w) = mkMachWordWrap dflags w
hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64Wrap       i
hsLitKey _      (HsWord64Prim _ w) = mkMachWord64Wrap      w
hsLitKey _      (HsCharPrim   _ c) = mkMachChar            c
hsLitKey _      (HsFloatPrim    f) = mkMachFloat           (fl_value f)
hsLitKey _      (HsDoublePrim   d) = mkMachDouble          (fl_value d)
hsLitKey _      (HsString _ s)     = MachStr (fastStringToByteString s)
395
hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
396

Austin Seipp's avatar
Austin Seipp committed
397 398 399
{-
************************************************************************
*                                                                      *
400
                Pattern matching on NPat
Austin Seipp's avatar
Austin Seipp committed
401 402 403
*                                                                      *
************************************************************************
-}
404

405
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
406
matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
407
  = do  { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1
408 409
        ; lit_expr <- dsOverLit lit
        ; neg_lit <- case mb_neg of
410 411 412
                            Nothing  -> return lit_expr
                            Just neg -> dsSyntaxExpr neg [lit_expr]
        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
413 414
        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
        ; return (mkGuardedMatchResult pred_expr match_result) }
415
matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
416

Austin Seipp's avatar
Austin Seipp committed
417 418 419
{-
************************************************************************
*                                                                      *
420
                Pattern matching on n+k patterns
Austin Seipp's avatar
Austin Seipp committed
421 422
*                                                                      *
************************************************************************
423

424 425 426 427
For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
    if ge var lit then
428 429
        let n = sub var lit
        in  <expr-for-a-successful-match>
430
    else
431
        <try-next-pattern-or-whatever>
432
\end{verbatim}
Austin Seipp's avatar
Austin Seipp committed
433
-}
434

435
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
Ian Lynagh's avatar
Ian Lynagh committed
436 437
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
438 439 440 441 442 443
  = do  { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
        ; lit1_expr   <- dsOverLit lit1
        ; lit2_expr   <- dsOverLit lit2
        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
444 445 446 447 448
        ; match_result <- match vars ty eqns'
        ; return  (mkGuardedMatchResult pred_expr               $
                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $
                   adjustMatchResult (foldr1 (.) wraps)         $
                   match_result) }
449
  where
450
    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
451 452
        = (wrapBind n n1, eqn { eqn_pats = pats })
        -- The wrapBind is a no-op for the first equation
Ian Lynagh's avatar
Ian Lynagh committed
453 454 455
    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)

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