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