compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Pattern-matching literal patterns
   7
   8 \begin{code}
   9 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
  10                   tidyLitPat, tidyNPat,
  11                   matchLiterals, matchNPlusKPats, matchNPats ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-} Match  ( match )
  16 import {-# SOURCE #-} DsExpr ( dsExpr )
  17
  18 import DsMonad
  19 import DsUtils
  20
  21 import HsSyn
  22
  23 import Id
  24 import CoreSyn
  25 import MkCore
  26 import TyCon
  27 import DataCon
  28 import TcHsSyn  ( shortCutLit )
  29 import TcType
  30 import PrelNames
  31 import TysWiredIn
  32 import Literal
  33 import SrcLoc
  34 import Data.Ratio
  35 import Outputable
  36 import Util
  37 import FastString
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42                 Desugaring literals
  43         [used to be in DsExpr, but DsMeta needs it,
  44          and it's nice to avoid a loop]
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 We give int/float literals type @Integer@ and @Rational@, respectively.
  49 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  50 around them.
  51
  52 ToDo: put in range checks for when converting ``@i@''
  53 (or should that be in the typechecker?)
  54
  55 For numeric literals, we try to detect there use at a standard type
  56 (@Int@, @Float@, etc.) are directly put in the right constructor.
  57 [NB: down with the @App@ conversion.]
  58
  59 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  60
  61 \begin{code}
  62 dsLit :: HsLit -> DsM CoreExpr
  63 dsLit (HsStringPrim s) = return (Lit (MachStr s))
  64 dsLit (HsCharPrim   c) = return (Lit (MachChar c))
  65 dsLit (HsIntPrim    i) = return (Lit (MachInt i))
  66 dsLit (HsWordPrim   w) = return (Lit (MachWord w))
  67 dsLit (HsFloatPrim  f) = return (Lit (MachFloat f))
  68 dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
  69
  70 dsLit (HsChar c)       = return (mkCharExpr c)
  71 dsLit (HsString str)   = mkStringExprFS str
  72 dsLit (HsInteger i _)  = mkIntegerExpr i
  73 dsLit (HsInt i)        = return (mkIntExpr i)
  74
  75 dsLit (HsRat r ty) = do
  76    num   <- mkIntegerExpr (numerator r)
  77    denom <- mkIntegerExpr (denominator r)
  78    return (mkConApp ratio_data_con [Type integer_ty, num, denom])
  79   where
  80     (ratio_data_con, integer_ty)
  81         = case tcSplitTyConApp ty of
  82                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  83                                    (head (tyConDataCons tycon), i_ty)
  84                 x -> pprPanic "dsLit" (ppr x)
  85
  86 dsOverLit :: HsOverLit Id -> DsM CoreExpr
  87 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
  88 -- (an expression for) the literal value itself
  89 dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
  90                    , ol_witness = witness, ol_type = ty })
  91   | not rebindable
  92   , Just expr <- shortCutLit val ty = dsExpr expr       -- Note [Literal short cut]
  93   | otherwise                       = dsExpr witness
  94 \end{code}
  95
  96 Note [Literal short cut]
  97 ~~~~~~~~~~~~~~~~~~~~~~~~
  98 The type checker tries to do this short-cutting as early as possible, but
  99 becuase of unification etc, more information is available to the desugarer.
 100 And where it's possible to generate the correct literal right away, it's
 101 much better do do so.
 102
 103
 104 \begin{code}
 105 hsLitKey :: HsLit -> Literal
 106 -- Get a Core literal to use (only) a grouping key
 107 -- Hence its type doesn't need to match the type of the original literal
 108 --      (and doesn't for strings)
 109 -- It only works for primitive types and strings;
 110 -- others have been removed by tidy
 111 hsLitKey (HsIntPrim     i) = mkMachInt  i
 112 hsLitKey (HsWordPrim    w) = mkMachWord w
 113 hsLitKey (HsCharPrim    c) = MachChar   c
 114 hsLitKey (HsStringPrim  s) = MachStr    s
 115 hsLitKey (HsFloatPrim   f) = MachFloat  f
 116 hsLitKey (HsDoublePrim  d) = MachDouble d
 117 hsLitKey (HsString s)      = MachStr    s
 118 hsLitKey l                 = pprPanic "hsLitKey" (ppr l)
 119
 120 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
 121 -- Ditto for HsOverLit; the boolean indicates to negate
 122 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
 123
 124 litValKey :: OverLitVal -> Bool -> Literal
 125 litValKey (HsIntegral i)   False = MachInt i
 126 litValKey (HsIntegral i)   True  = MachInt (-i)
 127 litValKey (HsFractional r) False = MachFloat r
 128 litValKey (HsFractional r) True  = MachFloat (-r)
 129 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr s
 130 \end{code}
 131
 132 %************************************************************************
 133 %*                                                                      *
 134         Tidying lit pats
 135 %*                                                                      *
 136 %************************************************************************
 137
 138 \begin{code}
 139 tidyLitPat :: HsLit -> Pat Id
 140 -- Result has only the following HsLits:
 141 --      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
 142 --      HsDoublePrim, HsStringPrim, HsString
 143 --  * HsInteger, HsRat, HsInt can't show up in LitPats
 144 --  * We get rid of HsChar right here
 145 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
 146 tidyLitPat (HsString s)
 147   | lengthFS s <= 1     -- Short string literals only
 148   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 149                   (mkNilPat stringTy) (unpackFS s)
 150         -- The stringTy is the type of the whole pattern, not
 151         -- the type to instantiate (:) or [] with!
 152 tidyLitPat lit = LitPat lit
 153
 154 ----------------
 155 tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat
 156                  -- We need this argument because tidyNPat is called
 157                  -- both by Match and by Check, but they tidy LitPats
 158                  -- slightly differently; and we must desugar
 159                  -- literals consistently (see Trac #5117)
 160          -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
 161          -> Pat Id
 162 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
 163         -- False: Take short cuts only if the literal is not using rebindable syntax
 164         --
 165         -- Once that is settled, look for cases where the type of the
 166         -- entire overloaded literal matches the type of the underlying literal,
 167         -- and in that case take the short cut
 168         -- NB: Watch out for wierd cases like Trac #3382
 169         --        f :: Int -> Int
 170         --        f "blah" = 4
 171         --     which might be ok if we hvae 'instance IsString Int'
 172         --
 173
 174   | isIntTy ty,    Just int_lit <- mb_int_lit = mk_con_pat intDataCon    (HsIntPrim    int_lit)
 175   | isWordTy ty,   Just int_lit <- mb_int_lit = mk_con_pat wordDataCon   (HsWordPrim   int_lit)
 176   | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
 177   | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
 178   | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
 179   where
 180     mk_con_pat :: DataCon -> HsLit -> Pat Id
 181     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
 182
 183     mb_int_lit :: Maybe Integer
 184     mb_int_lit = case (mb_neg, val) of
 185                    (Nothing, HsIntegral i) -> Just i
 186                    (Just _,  HsIntegral i) -> Just (-i)
 187                    _ -> Nothing
 188
 189     mb_rat_lit :: Maybe Rational
 190     mb_rat_lit = case (mb_neg, val) of
 191                    (Nothing, HsIntegral   i) -> Just (fromInteger i)
 192                    (Just _,  HsIntegral   i) -> Just (fromInteger (-i))
 193                    (Nothing, HsFractional f) -> Just f
 194                    (Just _, HsFractional f)  -> Just (-f)
 195                    _ -> Nothing
 196
 197     mb_str_lit :: Maybe FastString
 198     mb_str_lit = case (mb_neg, val) of
 199                    (Nothing, HsIsString s) -> Just s
 200                    _ -> Nothing
 201
 202 tidyNPat _ over_lit mb_neg eq
 203   = NPat over_lit mb_neg eq
 204 \end{code}
 205
 206
 207 %************************************************************************
 208 %*                                                                      *
 209                 Pattern matching on LitPat
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 matchLiterals :: [Id]
 215               -> Type                   -- Type of the whole case expression
 216               -> [[EquationInfo]]       -- All PgLits
 217               -> DsM MatchResult
 218
 219 matchLiterals (var:vars) ty sub_groups
 220   = ASSERT( all notNull sub_groups )
 221     do  {       -- Deal with each group
 222         ; alts <- mapM match_group sub_groups
 223
 224                 -- Combine results.  For everything except String
 225                 -- we can use a case expression; for String we need
 226                 -- a chain of if-then-else
 227         ; if isStringTy (idType var) then
 228             do  { eq_str <- dsLookupGlobalId eqStringName
 229                 ; mrs <- mapM (wrap_str_guard eq_str) alts
 230                 ; return (foldr1 combineMatchResults mrs) }
 231           else
 232             return (mkCoPrimCaseMatchResult var ty alts)
 233         }
 234   where
 235     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
 236     match_group eqns
 237         = do { let LitPat hs_lit = firstPat (head eqns)
 238              ; match_result <- match vars ty (shiftEqns eqns)
 239              ; return (hsLitKey hs_lit, match_result) }
 240
 241     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
 242         -- Equality check for string literals
 243     wrap_str_guard eq_str (MachStr s, mr)
 244         = do { lit    <- mkStringExprFS s
 245              ; let pred = mkApps (Var eq_str) [Var var, lit]
 246              ; return (mkGuardedMatchResult pred mr) }
 247     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
 248
 249 matchLiterals [] _ _ = panic "matchLiterals []"
 250 \end{code}
 251
 252
 253 %************************************************************************
 254 %*                                                                      *
 255                 Pattern matching on NPat
 256 %*                                                                      *
 257 %************************************************************************
 258
 259 \begin{code}
 260 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 261 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
 262   = do  { let NPat lit mb_neg eq_chk = firstPat eqn1
 263         ; lit_expr <- dsOverLit lit
 264         ; neg_lit <- case mb_neg of
 265                             Nothing -> return lit_expr
 266                             Just neg -> do { neg_expr <- dsExpr neg
 267                                            ; return (App neg_expr lit_expr) }
 268         ; eq_expr <- dsExpr eq_chk
 269         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 270         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
 271         ; return (mkGuardedMatchResult pred_expr match_result) }
 272 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
 273 \end{code}
 274
 275
 276 %************************************************************************
 277 %*                                                                      *
 278                 Pattern matching on n+k patterns
 279 %*                                                                      *
 280 %************************************************************************
 281
 282 For an n+k pattern, we use the various magic expressions we've been given.
 283 We generate:
 284 \begin{verbatim}
 285     if ge var lit then
 286         let n = sub var lit
 287         in  <expr-for-a-successful-match>
 288     else
 289         <try-next-pattern-or-whatever>
 290 \end{verbatim}
 291
 292
 293 \begin{code}
 294 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 295 -- All NPlusKPats, for the *same* literal k
 296 matchNPlusKPats (var:vars) ty (eqn1:eqns)
 297   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
 298         ; ge_expr     <- dsExpr ge
 299         ; minus_expr  <- dsExpr minus
 300         ; lit_expr    <- dsOverLit lit
 301         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 302               minusk_expr = mkApps minus_expr [Var var, lit_expr]
 303               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 304         ; match_result <- match vars ty eqns'
 305         ; return  (mkGuardedMatchResult pred_expr               $
 306                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
 307                    adjustMatchResult (foldr1 (.) wraps)         $
 308                    match_result) }
 309   where
 310     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 311         = (wrapBind n n1, eqn { eqn_pats = pats })
 312         -- The wrapBind is a no-op for the first equation
 313     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
 314
 315 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
 316 \end{code}