never executed always true always false
    1 
    2 {-# LANGUAGE ScopedTypeVariables #-}
    3 {-# LANGUAGE MultiWayIf          #-}
    4 {-# LANGUAGE TypeApplications    #-}
    5 {-# LANGUAGE AllowAmbiguousTypes #-}
    6 
    7 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    8 
    9 {-
   10 (c) The University of Glasgow 2006
   11 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   12 
   13 
   14 Pattern-matching literal patterns
   15 -}
   16 
   17 module GHC.HsToCore.Match.Literal
   18    ( dsLit, dsOverLit, hsLitKey
   19    , tidyLitPat, tidyNPat
   20    , matchLiterals, matchNPlusKPats, matchNPats
   21    , warnAboutIdentities
   22    , warnAboutOverflowedOverLit, warnAboutOverflowedLit
   23    , warnAboutEmptyEnumerations
   24    )
   25 where
   26 
   27 import GHC.Prelude
   28 import GHC.Platform
   29 
   30 import {-# SOURCE #-} GHC.HsToCore.Match ( match )
   31 import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr )
   32 
   33 import GHC.HsToCore.Errors.Types
   34 import GHC.HsToCore.Monad
   35 import GHC.HsToCore.Utils
   36 
   37 import GHC.Hs
   38 
   39 import GHC.Types.Id
   40 import GHC.Types.SourceText
   41 import GHC.Core
   42 import GHC.Core.Make
   43 import GHC.Core.TyCon
   44 import GHC.Core.Reduction ( Reduction(..) )
   45 import GHC.Core.DataCon
   46 import GHC.Tc.Utils.Zonk ( shortCutLit )
   47 import GHC.Tc.Utils.TcType
   48 import GHC.Types.Name
   49 import GHC.Core.Type
   50 import GHC.Builtin.Names
   51 import GHC.Builtin.Types
   52 import GHC.Builtin.Types.Prim
   53 import GHC.Types.Literal
   54 import GHC.Types.SrcLoc
   55 import GHC.Utils.Outputable as Outputable
   56 import GHC.Driver.Session
   57 import GHC.Utils.Misc
   58 import GHC.Utils.Panic
   59 import GHC.Utils.Panic.Plain
   60 import GHC.Data.FastString
   61 import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
   62 
   63 import Control.Monad
   64 import Data.Int
   65 import Data.List.NonEmpty (NonEmpty(..))
   66 import qualified Data.List.NonEmpty as NEL
   67 import Data.Word
   68 import GHC.Real ( Ratio(..), numerator, denominator )
   69 
   70 {-
   71 ************************************************************************
   72 *                                                                      *
   73                 Desugaring literals
   74  [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it,
   75   and it's nice to avoid a loop]
   76 *                                                                      *
   77 ************************************************************************
   78 
   79 We give int/float literals type @Integer@ and @Rational@, respectively.
   80 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
   81 around them.
   82 
   83 ToDo: put in range checks for when converting ``@i@''
   84 (or should that be in the typechecker?)
   85 
   86 For numeric literals, we try to detect there use at a standard type
   87 (@Int@, @Float@, etc.) are directly put in the right constructor.
   88 [NB: down with the @App@ conversion.]
   89 
   90 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
   91 -}
   92 
   93 dsLit :: HsLit GhcRn -> DsM CoreExpr
   94 dsLit l = do
   95   dflags <- getDynFlags
   96   let platform = targetPlatform dflags
   97   case l of
   98     HsStringPrim _ s -> return (Lit (LitString s))
   99     HsCharPrim   _ c -> return (Lit (LitChar c))
  100     HsIntPrim    _ i -> return (Lit (mkLitIntWrap platform i))
  101     HsWordPrim   _ w -> return (Lit (mkLitWordWrap platform w))
  102     HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap i))
  103     HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w))
  104 
  105     -- This can be slow for very large literals. See Note [FractionalLit representation]
  106     -- and #15646
  107     HsFloatPrim  _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl)))
  108     HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
  109     HsChar _ c       -> return (mkCharExpr c)
  110     HsString _ str   -> mkStringExprFS str
  111     HsInteger _ i _  -> return (mkIntegerExpr platform i)
  112     HsInt _ i        -> return (mkIntExpr platform (il_value i))
  113     HsRat _ fl ty    -> dsFractionalLitToRational fl ty
  114 
  115 {-
  116 Note [FractionalLit representation]
  117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  118 There is a fun wrinkle to this, we used to simply compute the value
  119 for these literals and store it as `Rational`. While this might seem
  120 reasonable it meant typechecking literals of extremely large numbers
  121 wasn't possible. This happend for example in #15646.
  122 
  123 There a user would write in GHCi e.g. `:t 1e1234111111111111111111111`
  124 which would trip up the compiler. The reason being we would parse it as
  125 <Literal of value n>. Try to compute n, which would run out of memory
  126 for truly large numbers, or take far too long for merely large ones.
  127 
  128 To fix this we instead now store the significand and exponent of the
  129 literal instead. Depending on the size of the exponent we then defer
  130 the computation of the Rational value, potentially up to runtime of the
  131 program! There are still cases left were we might compute large rationals
  132 but it's a lot rarer then.
  133 
  134 The current state of affairs for large literals is:
  135 * Typechecking: Will produce a FractionalLit
  136 * Desugaring a large overloaded literal to Float/Double *is* done
  137   at compile time. So can still fail. But this only matters for values too large
  138   to be represented as float anyway.
  139 * Converting overloaded literals to a value of *Rational* is done at *runtime*.
  140   If such a value is then demanded at runtime the program might hang or run out of
  141   memory. But that is perhaps expected and acceptable.
  142 * TH might also evaluate the literal even when overloaded.
  143   But there a user should be able to work around #15646 by
  144   generating a call to `mkRationalBase10/2` for large literals instead.
  145 
  146 
  147 Note [FractionalLit representation]
  148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  149 For fractional literals, like 1.3 or 0.79e22, we do /not/ represent
  150 them within the compiler as a Rational.  Doing so would force the
  151 compiler to compute a huge Rational for 2.3e300000000000, at compile
  152 time (#15646)!
  153 
  154 So instead we represent fractional literals as a FractionalLit,
  155 in which we record the significand and exponent separately.  Then
  156 we can compute the huge Rational at /runtime/, by emitting code
  157 for
  158        mkRationalBase10 2.3 300000000000
  159 
  160 where mkRationalBase10 is defined in the library GHC.Real
  161 
  162 The moving parts are here:
  163 
  164 * Parsing, renaming, typechecking: use FractionalLit, in which the
  165   significand and exponent are represented separately.
  166 
  167 * Desugaring.  Remember that a fractional literal like 54.4e20 has type
  168      Fractional a => a
  169 
  170   - For fractional literals whose type turns out to be Float/Double,
  171     we desugar to a Float/Double literal at /compile time/.
  172     This conversion can still fail. But this only matters for values
  173     too large to be represented as float anyway.  See dsLit in
  174     GHC.HsToCore.Match.Literal
  175 
  176   - For fractional literals whose type turns out to be Rational, we
  177     desugar the literal to a call of `mkRationalBase10` (etc for hex
  178     literals), so that we only compute the Rational at /run time/.  If
  179     this value is then demanded at runtime the program might hang or
  180     run out of memory. But that is perhaps expected and acceptable.
  181     See dsFractionalLitToRational in GHC.HsToCore.Match.Literal
  182 
  183   - For fractional literals whose type isn't one of the above, we just
  184     call the typeclass method `fromRational`.  But to do that we need
  185     the rational to give to it, and we compute that at runtime, as
  186     above.
  187 
  188 * Template Haskell definitions are also problematic. While the TH code
  189   works as expected once it's spliced into a program it will compute the
  190   value of the large literal.
  191   But there a user should be able to work around #15646
  192   by having their TH code generating a call to `mkRationalBase[10/2]` for
  193   large literals  instead.
  194 
  195 -}
  196 
  197 -- | See Note [FractionalLit representation]
  198 dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
  199 dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty
  200   -- We compute "small" rationals here and now
  201   | abs exp <= 100
  202   = do
  203     platform <- targetPlatform <$> getDynFlags
  204     let !val   = rationalFromFractionalLit fl
  205         !num   = mkIntegerExpr platform (numerator val)
  206         !denom = mkIntegerExpr platform (denominator val)
  207         (ratio_data_con, integer_ty)
  208             = case tcSplitTyConApp ty of
  209                     (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  210                                        (head (tyConDataCons tycon), i_ty)
  211                     x -> pprPanic "dsLit" (ppr x)
  212     return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
  213   -- Large rationals will be computed at runtime.
  214   | otherwise
  215   = do
  216       let mkRationalName = case base of
  217                              Base2 -> mkRationalBase2Name
  218                              Base10 -> mkRationalBase10Name
  219       mkRational <- dsLookupGlobalId mkRationalName
  220       litR <- dsRational signi
  221       platform <- targetPlatform <$> getDynFlags
  222       let litE = mkIntegerExpr platform exp
  223       return (mkCoreApps (Var mkRational) [litR, litE])
  224 
  225 dsRational :: Rational -> DsM CoreExpr
  226 dsRational (n :% d) = do
  227   platform <- targetPlatform <$> getDynFlags
  228   dcn <- dsLookupDataCon ratioDataConName
  229   let cn = mkIntegerExpr platform n
  230   let dn = mkIntegerExpr platform d
  231   return $ mkCoreConApps dcn [Type integerTy, cn, dn]
  232 
  233 
  234 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
  235 -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
  236 -- (an expression for) the literal value itself.
  237 dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do
  238   dflags <- getDynFlags
  239   let platform = targetPlatform dflags
  240   case shortCutLit platform val ty of
  241     Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]
  242     _                          -> dsExpr witness
  243 
  244 {-
  245 Note [Literal short cut]
  246 ~~~~~~~~~~~~~~~~~~~~~~~~
  247 The type checker tries to do this short-cutting as early as possible, but
  248 because of unification etc, more information is available to the desugarer.
  249 And where it's possible to generate the correct literal right away, it's
  250 much better to do so.
  251 
  252 
  253 ************************************************************************
  254 *                                                                      *
  255                  Warnings about overflowed literals
  256 *                                                                      *
  257 ************************************************************************
  258 
  259 Warn about functions like toInteger, fromIntegral, that convert
  260 between one type and another when the to- and from- types are the
  261 same.  Then it's probably (albeit not definitely) the identity
  262 -}
  263 
  264 warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()
  265 warnAboutIdentities dflags conv_fn type_of_conv
  266   | wopt Opt_WarnIdentities dflags
  267   , idName conv_fn `elem` conversionNames
  268   , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
  269   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
  270   = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv)
  271 warnAboutIdentities _ _ _ = return ()
  272 
  273 conversionNames :: [Name]
  274 conversionNames
  275   = [ toIntegerName, toRationalName
  276     , fromIntegralName, realToFracName ]
  277  -- We can't easily add fromIntegerName, fromRationalName,
  278  -- because they are generated by literals
  279 
  280 
  281 -- | Emit warnings on overloaded integral literals which overflow the bounds
  282 -- implied by their type.
  283 warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
  284 warnAboutOverflowedOverLit hsOverLit = do
  285   dflags <- getDynFlags
  286   fam_envs <- dsGetFamInstEnvs
  287   warnAboutOverflowedLiterals dflags $
  288       getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs
  289 
  290 -- | Emit warnings on integral literals which overflow the bounds implied by
  291 -- their type.
  292 warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
  293 warnAboutOverflowedLit hsLit = do
  294   dflags <- getDynFlags
  295   warnAboutOverflowedLiterals dflags $
  296       getSimpleIntegralLit hsLit >>= getTyconName
  297 
  298 -- | Emit warnings on integral literals which overflow the bounds implied by
  299 -- their type.
  300 warnAboutOverflowedLiterals
  301   :: DynFlags
  302   -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon
  303   -> DsM ()
  304 warnAboutOverflowedLiterals dflags lit
  305  | wopt Opt_WarnOverflowedLiterals dflags
  306  , Just (i, tc) <- lit
  307  = if
  308     -- These only show up via the 'HsOverLit' route
  309     | tc == intTyConName        -> check i tc minInt         maxInt
  310     | tc == wordTyConName       -> check i tc minWord        maxWord
  311     | tc == int8TyConName       -> check i tc (min' @Int8)   (max' @Int8)
  312     | tc == int16TyConName      -> check i tc (min' @Int16)  (max' @Int16)
  313     | tc == int32TyConName      -> check i tc (min' @Int32)  (max' @Int32)
  314     | tc == int64TyConName      -> check i tc (min' @Int64)  (max' @Int64)
  315     | tc == word8TyConName      -> check i tc (min' @Word8)  (max' @Word8)
  316     | tc == word16TyConName     -> check i tc (min' @Word16) (max' @Word16)
  317     | tc == word32TyConName     -> check i tc (min' @Word32) (max' @Word32)
  318     | tc == word64TyConName     -> check i tc (min' @Word64) (max' @Word64)
  319     | tc == naturalTyConName    -> checkPositive i tc
  320 
  321     -- These only show up via the 'HsLit' route
  322     | tc == intPrimTyConName    -> check i tc minInt         maxInt
  323     | tc == wordPrimTyConName   -> check i tc minWord        maxWord
  324     | tc == int8PrimTyConName   -> check i tc (min' @Int8)   (max' @Int8)
  325     | tc == int16PrimTyConName  -> check i tc (min' @Int16)  (max' @Int16)
  326     | tc == int32PrimTyConName  -> check i tc (min' @Int32)  (max' @Int32)
  327     | tc == int64PrimTyConName  -> check i tc (min' @Int64)  (max' @Int64)
  328     | tc == word8PrimTyConName  -> check i tc (min' @Word8)  (max' @Word8)
  329     | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
  330     | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
  331     | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
  332 
  333     | otherwise -> return ()
  334 
  335   | otherwise = return ()
  336   where
  337     -- use target Int/Word sizes! See #17336
  338     platform          = targetPlatform dflags
  339     (minInt,maxInt)   = (platformMinInt platform, platformMaxInt platform)
  340     (minWord,maxWord) = (0,                       platformMaxWord platform)
  341 
  342     min' :: forall a. (Integral a, Bounded a) => Integer
  343     min' = fromIntegral (minBound :: a)
  344 
  345     max' :: forall a. (Integral a, Bounded a) => Integer
  346     max' = fromIntegral (maxBound :: a)
  347 
  348     checkPositive :: Integer -> Name -> DsM ()
  349     checkPositive i tc
  350       = when (i < 0) $
  351         diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags))
  352 
  353     check i tc minB maxB
  354       = when (i < minB || i > maxB) $
  355         diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags))
  356       where
  357         bounds = Just (MinBound minB, MaxBound maxB)
  358 
  359 warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
  360                            -> Maybe (LHsExpr GhcTc)
  361                            -> LHsExpr GhcTc -> DsM ()
  362 -- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list.
  363 -- For numeric literals, only works for integral types, not floating point.
  364 warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
  365   | not $ wopt Opt_WarnEmptyEnumerations dflags
  366   = return ()
  367   -- Numeric Literals
  368   | Just from_ty@(from',_) <- getLHsIntegralLit fromExpr
  369   , Just (_, tc)           <- getNormalisedTyconName fam_envs from_ty
  370   , Just mThn'             <- traverse getLHsIntegralLit mThnExpr
  371   , Just (to',_)           <- getLHsIntegralLit toExpr
  372   = do
  373       let
  374         check :: forall a. (Integral a, Num a) => DsM ()
  375         check = when (null enumeration) raiseWarning
  376           where
  377             enumeration = case mThn of
  378               Nothing  -> [from      .. to]
  379               Just thn -> [from, thn .. to]
  380             wrap :: forall a. (Integral a, Num a) => Integer -> Integer
  381             wrap i = toInteger (fromIntegral i :: a)
  382             from = wrap @a from'
  383             to   = wrap @a to'
  384             mThn = fmap (wrap @a . fst) mThn'
  385 
  386       platform <- targetPlatform <$> getDynFlags
  387          -- Be careful to use target Int/Word sizes! cf #17336
  388       if | tc == intTyConName     -> case platformWordSize platform of
  389                                       PW4 -> check @Int32
  390                                       PW8 -> check @Int64
  391          | tc == wordTyConName    -> case platformWordSize platform of
  392                                       PW4 -> check @Word32
  393                                       PW8 -> check @Word64
  394          | tc == int8TyConName    -> check @Int8
  395          | tc == int16TyConName   -> check @Int16
  396          | tc == int32TyConName   -> check @Int32
  397          | tc == int64TyConName   -> check @Int64
  398          | tc == word8TyConName   -> check @Word8
  399          | tc == word16TyConName  -> check @Word16
  400          | tc == word32TyConName  -> check @Word32
  401          | tc == word64TyConName  -> check @Word64
  402          | tc == integerTyConName -> check @Integer
  403          | tc == naturalTyConName -> check @Integer
  404             -- We use 'Integer' because otherwise a negative 'Natural' literal
  405             -- could cause a compile time crash (instead of a runtime one).
  406             -- See the T10930b test case for an example of where this matters.
  407          | otherwise -> return ()
  408 
  409   -- Char literals (#18402)
  410   | Just fromChar <- getLHsCharLit fromExpr
  411   , Just mThnChar <- traverse getLHsCharLit mThnExpr
  412   , Just toChar   <- getLHsCharLit toExpr
  413   , let enumeration = case mThnChar of
  414                         Nothing      -> [fromChar          .. toChar]
  415                         Just thnChar -> [fromChar, thnChar .. toChar]
  416   = when (null enumeration) raiseWarning
  417 
  418   | otherwise = return ()
  419   where
  420     raiseWarning =
  421       diagnosticDs DsEmptyEnumeration
  422 
  423 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
  424 -- ^ See if the expression is an 'Integral' literal.
  425 getLHsIntegralLit (L _ e) = go e
  426   where
  427     go (HsPar _ _ e _)        = getLHsIntegralLit e
  428     go (HsOverLit _ over_lit) = getIntegralLit over_lit
  429     go (HsLit _ lit)          = getSimpleIntegralLit lit
  430 
  431     -- Remember to look through automatically-added tick-boxes! (#8384)
  432     go (XExpr (HsTick _ e))       = getLHsIntegralLit e
  433     go (XExpr (HsBinTick _ _ e))  = getLHsIntegralLit e
  434 
  435     -- The literal might be wrapped in a case with -XOverloadedLists
  436     go (XExpr (WrapExpr (HsWrap _ e))) = go e
  437     go _ = Nothing
  438 
  439 -- | If 'Integral', extract the value and type of the overloaded literal.
  440 -- See Note [Literals and the OverloadedLists extension]
  441 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
  442 getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } })
  443   = Just (il_value i, ty)
  444 getIntegralLit _ = Nothing
  445 
  446 -- | If 'Integral', extract the value and type of the non-overloaded literal.
  447 getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
  448 getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)
  449 getSimpleIntegralLit (HsIntPrim _ i)    = Just (i, intPrimTy)
  450 getSimpleIntegralLit (HsWordPrim _ i)   = Just (i, wordPrimTy)
  451 getSimpleIntegralLit (HsInt64Prim _ i)  = Just (i, int64PrimTy)
  452 getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
  453 getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)
  454 getSimpleIntegralLit _ = Nothing
  455 
  456 -- | Extract the Char if the expression is a Char literal.
  457 getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
  458 getLHsCharLit (L _ (HsPar _ _ e _))        = getLHsCharLit e
  459 getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c
  460 getLHsCharLit (L _ (XExpr (HsTick _ e)))         = getLHsCharLit e
  461 getLHsCharLit (L _ (XExpr (HsBinTick _ _ e)))    = getLHsCharLit e
  462 getLHsCharLit _ = Nothing
  463 
  464 -- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
  465 -- normalising the type
  466 getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
  467 getNormalisedTyconName fam_envs (i,ty)
  468     | Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty)
  469     = Just (i, tyConName tc)
  470     | otherwise = Nothing
  471   where
  472     normaliseNominal :: FamInstEnvs -> Type -> Type
  473     normaliseNominal fam_envs ty
  474       = reductionReducedType
  475       $ normaliseType fam_envs Nominal ty
  476 
  477 -- | Convert a pair (Integer, Type) to (Integer, Name) without normalising
  478 -- the type
  479 getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
  480 getTyconName (i,ty)
  481   | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc)
  482   | otherwise = Nothing
  483 
  484 {-
  485 Note [Literals and the OverloadedLists extension]
  486 ~~~~
  487 Consider the Literal `[256] :: [Data.Word.Word8]`
  488 
  489 When the `OverloadedLists` extension is not active, then the `ol_ext` field
  490 in the `OverLitTc` record that is passed to the function `getIntegralLit`
  491 contains the type `Word8`. This is a simple type, and we can use its
  492 type constructor immediately for the `warnAboutOverflowedLiterals` function.
  493 
  494 When the `OverloadedLists` extension is active, then the `ol_ext` field
  495 contains the type family `Item [Word8]`. The function `nomaliseType` is used
  496 to convert it to the needed type `Word8`.
  497 -}
  498 
  499 {-
  500 ************************************************************************
  501 *                                                                      *
  502         Tidying lit pats
  503 *                                                                      *
  504 ************************************************************************
  505 -}
  506 
  507 tidyLitPat :: HsLit GhcTc -> Pat GhcTc
  508 -- Result has only the following HsLits:
  509 --      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
  510 --      HsDoublePrim, HsStringPrim, HsString
  511 --  * HsInteger, HsRat, HsInt can't show up in LitPats
  512 --  * We get rid of HsChar right here
  513 tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
  514 tidyLitPat (HsString src s)
  515   | lengthFS s <= 1     -- Short string literals only
  516   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
  517                                              [mkCharLitPat src c, pat] [charTy])
  518                   (mkNilPat charTy) (unpackFS s)
  519         -- The stringTy is the type of the whole pattern, not
  520         -- the type to instantiate (:) or [] with!
  521 tidyLitPat lit = LitPat noExtField lit
  522 
  523 ----------------
  524 tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
  525          -> Type
  526          -> Pat GhcTc
  527 tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
  528         -- False: Take short cuts only if the literal is not using rebindable syntax
  529         --
  530         -- Once that is settled, look for cases where the type of the
  531         -- entire overloaded literal matches the type of the underlying literal,
  532         -- and in that case take the short cut
  533         -- NB: Watch out for weird cases like #3382
  534         --        f :: Int -> Int
  535         --        f "blah" = 4
  536         --     which might be ok if we have 'instance IsString Int'
  537         --
  538   | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
  539                  = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
  540   | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
  541                  = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
  542   | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
  543                  = tidyLitPat (HsString NoSourceText str_lit)
  544      -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
  545      -- If we do convert to the constructor form, we'll generate a case
  546      -- expression on a Float# or Double# and that's not allowed in Core; see
  547      -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold
  548   where
  549     -- Sometimes (like in test case
  550     -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
  551     -- type-changing wrappers (for example, from Id Int to Int, for the identity
  552     -- type family Id). In these cases, we can't do the short-cut.
  553     type_change = not (outer_ty `eqType` ty)
  554 
  555     mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
  556     mk_con_pat con lit
  557       = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] [])
  558 
  559     mb_int_lit :: Maybe Integer
  560     mb_int_lit = case (mb_neg, val) of
  561                    (Nothing, HsIntegral i) -> Just (il_value i)
  562                    (Just _,  HsIntegral i) -> Just (-(il_value i))
  563                    _ -> Nothing
  564 
  565     mb_str_lit :: Maybe FastString
  566     mb_str_lit = case (mb_neg, val) of
  567                    (Nothing, HsIsString _ s) -> Just s
  568                    _ -> Nothing
  569 
  570 tidyNPat over_lit mb_neg eq outer_ty
  571   = NPat outer_ty (noLocA over_lit) mb_neg eq
  572 
  573 {-
  574 ************************************************************************
  575 *                                                                      *
  576                 Pattern matching on LitPat
  577 *                                                                      *
  578 ************************************************************************
  579 -}
  580 
  581 matchLiterals :: NonEmpty Id
  582               -> Type -- ^ Type of the whole case expression
  583               -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
  584               -> DsM (MatchResult CoreExpr)
  585 
  586 matchLiterals (var :| vars) ty sub_groups
  587   = do  {       -- Deal with each group
  588         ; alts <- mapM match_group sub_groups
  589 
  590                 -- Combine results.  For everything except String
  591                 -- we can use a case expression; for String we need
  592                 -- a chain of if-then-else
  593         ; if isStringTy (idType var) then
  594             do  { eq_str <- dsLookupGlobalId eqStringName
  595                 ; mrs <- mapM (wrap_str_guard eq_str) alts
  596                 ; return (foldr1 combineMatchResults mrs) }
  597           else
  598             return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
  599         }
  600   where
  601     match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
  602     match_group eqns@(firstEqn :| _)
  603         = do { dflags <- getDynFlags
  604              ; let platform = targetPlatform dflags
  605              ; let LitPat _ hs_lit = firstPat firstEqn
  606              ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
  607              ; return (hsLitKey platform hs_lit, match_result) }
  608 
  609     wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
  610         -- Equality check for string literals
  611     wrap_str_guard eq_str (LitString s, mr)
  612         = do { -- We now have to convert back to FastString. Perhaps there
  613                -- should be separate LitBytes and LitString constructors?
  614                let s'  = mkFastStringByteString s
  615              ; lit    <- mkStringExprFS s'
  616              ; let pred = mkApps (Var eq_str) [Var var, lit]
  617              ; return (mkGuardedMatchResult pred mr) }
  618     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
  619 
  620 
  621 ---------------------------
  622 hsLitKey :: Platform -> HsLit GhcTc -> Literal
  623 -- Get the Core literal corresponding to a HsLit.
  624 -- It only works for primitive types and strings;
  625 -- others have been removed by tidy
  626 -- For HsString, it produces a LitString, which really represents an _unboxed_
  627 -- string literal; and we deal with it in matchLiterals above. Otherwise, it
  628 -- produces a primitive Literal of type matching the original HsLit.
  629 -- In the case of the fixed-width numeric types, we need to wrap here
  630 -- because Literal has an invariant that the literal is in range, while
  631 -- HsLit does not.
  632 hsLitKey platform (HsIntPrim    _ i)  = mkLitIntWrap  platform i
  633 hsLitKey platform (HsWordPrim   _ w)  = mkLitWordWrap platform w
  634 hsLitKey _        (HsInt64Prim  _ i)  = mkLitInt64Wrap  i
  635 hsLitKey _        (HsWord64Prim _ w)  = mkLitWord64Wrap w
  636 hsLitKey _        (HsCharPrim   _ c)  = mkLitChar            c
  637 -- This following two can be slow. See Note [FractionalLit representation]
  638 hsLitKey _        (HsFloatPrim  _ fl) = mkLitFloat (rationalFromFractionalLit fl)
  639 hsLitKey _        (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)
  640 
  641 hsLitKey _        (HsString _ s)      = LitString (bytesFS s)
  642 hsLitKey _        l                   = pprPanic "hsLitKey" (ppr l)
  643 
  644 {-
  645 ************************************************************************
  646 *                                                                      *
  647                 Pattern matching on NPat
  648 *                                                                      *
  649 ************************************************************************
  650 -}
  651 
  652 matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
  653 matchNPats (var :| vars) ty (eqn1 :| eqns)    -- All for the same literal
  654   = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
  655         ; lit_expr <- dsOverLit lit
  656         ; neg_lit <- case mb_neg of
  657                             Nothing  -> return lit_expr
  658                             Just neg -> dsSyntaxExpr neg [lit_expr]
  659         ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
  660         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
  661         ; return (mkGuardedMatchResult pred_expr match_result) }
  662 
  663 {-
  664 ************************************************************************
  665 *                                                                      *
  666                 Pattern matching on n+k patterns
  667 *                                                                      *
  668 ************************************************************************
  669 
  670 For an n+k pattern, we use the various magic expressions we've been given.
  671 We generate:
  672 \begin{verbatim}
  673     if ge var lit then
  674         let n = sub var lit
  675         in  <expr-for-a-successful-match>
  676     else
  677         <try-next-pattern-or-whatever>
  678 \end{verbatim}
  679 -}
  680 
  681 matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
  682 -- All NPlusKPats, for the *same* literal k
  683 matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
  684   = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
  685                 = firstPat eqn1
  686         ; lit1_expr   <- dsOverLit lit1
  687         ; lit2_expr   <- dsOverLit lit2
  688         ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
  689         ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
  690         ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
  691         ; match_result <- match vars ty eqns'
  692         ; return  (mkGuardedMatchResult pred_expr               $
  693                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
  694                    fmap (foldr1 (.) wraps)                      $
  695                    match_result) }
  696   where
  697     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
  698         = (wrapBind n n1, eqn { eqn_pats = pats })
  699         -- The wrapBind is a no-op for the first equation
  700     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)